1# Copyright (c) 2016 CentralNic Ltd. All rights reserved. This program is 2# free software; you can redistribute it and/or modify it under the same 3# terms as Perl itself. 4# 5# $Id: Simple.pm,v 1.10 2011/04/08 12:57:11 gavin Exp $ 6package Net::EPP::Simple; 7use Carp; 8use Digest::SHA qw(sha1_hex); 9use Net::EPP::Frame; 10use Net::EPP::ResponseCodes; 11use Time::HiRes qw(time); 12use base qw(Net::EPP::Client); 13use constant EPP_XMLNS => 'urn:ietf:params:xml:ns:epp-1.0'; 14use vars qw($Error $Code $Message @Log); 15use strict; 16use warnings; 17 18our $Error = ''; 19our $Code = OK; 20our $Message = ''; 21our @Log = (); 22 23=pod 24 25=head1 Name 26 27Net::EPP::Simple - a simple EPP client interface for the most common jobs 28 29=head1 Synopsis 30 31 #!/usr/bin/perl 32 use Net::EPP::Simple; 33 use strict; 34 35 my $epp = Net::EPP::Simple->new( 36 host => 'epp.nic.tld', 37 user => 'my-id', 38 pass => 'my-password', 39 ); 40 41 my $domain = 'example.tld'; 42 43 if ($epp->check_domain($domain) == 1) { 44 print "Domain is available\n" ; 45 46 } else { 47 my $info = $epp->domain_info($domain); 48 printf("Domain was registered on %s by %s\n", $info->{crDate}, $info->{crID}); 49 50 } 51 52=head1 Description 53 54EPP is the Extensible Provisioning Protocol. EPP (defined in RFC 4930) is an 55application layer client-server protocol for the provisioning and management of 56objects stored in a shared central repository. Specified in XML, the protocol 57defines generic object management operations and an extensible framework that 58maps protocol operations to objects. As of writing, its only well-developed 59application is the provisioning of Internet domain names, hosts, and related 60contact details. 61 62This module provides a high level interface to the EPP protocol. It hides all 63the boilerplate of connecting, logging in, building request frames and parsing 64response frames behind a simple, Perlish interface. 65 66It is based on the C<Net::EPP::Client> module and uses C<Net::EPP::Frame> 67to build request frames. 68 69=head1 Constructor 70 71The constructor for C<Net::EPP::Simple> has the same general form as the 72one for C<Net::EPP::Client>, but with the following exceptions: 73 74=over 75 76=item * Unless otherwise set, C<port> defaults to 700 77 78=item * Unless the C<no_ssl> parameter is set, SSL is always on 79 80=item * You can use the C<user> and C<pass> parameters to supply authentication information. 81 82=item * The C<timeout> parameter controls how long the client waits for a response from the server before returning an error. 83 84=item * if C<debug> is set, C<Net::EPP::Simple> will output verbose debugging information on C<STDERR>, including all frames sent to and received from the server. 85 86=item * C<reconnect> can be used to disable automatic reconnection (it is enabled by default). Before sending a frame to the server, C<Net::EPP::Simple> will send a C<E<lt>helloE<gt>> to check that the connection is up, if not, it will try to reconnect, aborting after the I<n>th time, where I<n> is the value of C<reconnect> (the default is 3). 87 88=item * C<login> can be used to disable automatic logins. If you set it to C<0>, you can manually log in using the C<$epp->_login()> method. 89 90=item * C<objects> is a reference to an array of the EPP object schema 91URIs that the client requires. 92 93=item * C<stdobj> is a flag saying the client only requires the 94standard EPP C<contact-1.0>, C<domain-1.0>, and C<host-1.0> schemas. 95 96=item * If neither C<objects> nor C<stdobj> is specified then the 97client will echo the server's object schema list. 98 99=item * C<extensions> is a reference to an array of the EPP extension 100schema URIs that the client requires. 101 102=item * C<stdext> is a flag saying the client only requires the 103standard EPP C<secDNS-1.1> DNSSEC extension schema. 104 105=item * If neither C<extensions> nor C<stdext> is specified then the 106client will echo the server's extension schema list. 107 108=back 109 110The constructor will establish a connection to the server and retrieve the 111greeting (which is available via $epp-E<gt>{greeting}) and then send a 112E<lt>loginE<gt> request. 113 114If the login fails, the constructor will return C<undef> and set 115C<$Net::EPP::Simple::Error> and C<$Net::EPP::Simple::Code>. 116 117=head2 Client and Server SSL options 118 119RFC 5730 requires that all EPP instances must be protected using "mutual, 120strong client-server authentication". In practice, this means that both 121client and server must present an SSL certificate, and that they must 122both verify the certificate of their peer. 123 124=head3 Server Certificate Verification 125 126C<Net::EPP::Simple> will verify the certificate presented by a server if 127the C<verify>, and either C<ca_file> or C<ca_path> are passed to the 128constructor: 129 130 my $epp = Net::EPP::Simple->new( 131 host => 'epp.nic.tld', 132 user => 'my-id', 133 pass => 'my-password', 134 verify => 1, 135 ca_file => '/etc/pki/tls/certs/ca-bundle.crt', 136 ca_path => '/etc/pki/tls/certs', 137 ); 138 139C<Net::EPP::Simple> will fail to connect to the server if the 140certificate is not valid. 141 142You can disable SSL certificate verification by omitting the C<verify> 143argument or setting it to C<undef>. This is strongly discouraged, 144particularly in production environments. 145 146=head3 SSL Cipher Selection 147 148You can restrict the ciphers that you will use to connect to the server 149by passing a C<ciphers> parameter to the constructor. This is a colon- 150separated list of cipher names and aliases. See L<http://www.openssl.org/docs/apps/ciphers.html#CIPHER_STRINGS> 151for further details. As an example, the following cipher list is 152suggested for clients who wish to ensure high-security connections to 153servers: 154 155 HIGH:!ADH:!MEDIUM:!LOW:!SSLv2:!EXP 156 157=head3 Client Certificates 158 159If you are connecting to an EPP server which requires a client 160certificate, you can configure C<Net::EPP::Simple> to use one as 161follows: 162 163 my $epp = Net::EPP::Simple->new( 164 host => 'epp.nic.tld', 165 user => 'my-id', 166 pass => 'my-password', 167 key => '/path/to/my.key', 168 cert => '/path/to/my.crt', 169 passphrase => 'foobar123', 170 ); 171 172C<key> is the filename of the private key, C<cert> is the filename of 173the certificate. If the private key is encrypted, the C<passphrase> 174parameter will be used to decrypt it. 175 176=head2 Configuration File 177 178C<Net::EPP::Simple> supports the use of a simple configuration file. To 179use this feature, you need to install the L<Config::Simple> module. 180 181When starting up, C<Net::EPP::Simple> will look for 182C<$HOME/.net-epp-simple-rc>. This file is an ini-style configuration 183file. 184 185=head3 Default Options 186 187You can specify default options for all EPP servers using the C<[default]> 188section: 189 190 [default] 191 default=epp.nic.tld 192 debug=1 193 194=head3 Server Specific Options 195 196You can specify options for for specific EPP servers by giving each EPP server 197its own section: 198 199 [epp.nic.tld] 200 user=abc123 201 pass=foo2bar 202 port=777 203 ssl=0 204 205This means that when you write a script that uses C<Net::EPP::Simple>, you can 206do the following: 207 208 # config file has a default server: 209 my $epp = Net::EPP::Simple->new; 210 211 # config file has connection options for this EPP server: 212 my $epp = Net::EPP:Simple->new('host' => 'epp.nic.tld'); 213 214Any parameters provided to the constructor will override those in the config 215file. 216 217=cut 218 219sub new { 220 my ($package, %params) = @_; 221 $params{dom} = 1; 222 223 my $load_config = (defined($params{load_config}) ? $params{load_config} : 1); 224 $package->_load_config(\%params) if ($load_config); 225 226 $params{port} = (defined($params{port}) && int($params{port}) > 0 ? $params{port} : 700); 227 $params{ssl} = ($params{no_ssl} ? undef : 1); 228 229 my $self = $package->SUPER::new(%params); 230 231 $self->{user} = $params{user}; 232 $self->{pass} = $params{pass}; 233 $self->{debug} = (defined($params{debug}) ? int($params{debug}) : undef); 234 $self->{timeout} = (defined($params{timeout}) && int($params{timeout}) > 0 ? $params{timeout} : 5); 235 $self->{reconnect} = (defined($params{reconnect}) ? int($params{reconnect}) : 3); 236 $self->{connected} = undef; 237 $self->{authenticated} = undef; 238 $self->{connect} = (exists($params{connect}) ? $params{connect} : 1); 239 $self->{login} = (exists($params{login}) ? $params{login} : 1); 240 $self->{key} = $params{key}; 241 $self->{cert} = $params{cert}; 242 $self->{passphrase} = $params{passphrase}; 243 $self->{verify} = $params{verify}; 244 $self->{ca_file} = $params{ca_file}; 245 $self->{ca_path} = $params{ca_path}; 246 $self->{ciphers} = $params{ciphers}; 247 $self->{objects} = $params{objects}; 248 $self->{stdobj} = $params{stdobj}; 249 $self->{extensions} = $params{extensions}; 250 $self->{stdext} = $params{stdext}; 251 252 bless($self, $package); 253 254 if ($self->{connect}) { 255 return ($self->_connect($self->{login}) ? $self : undef); 256 257 } else { 258 return $self; 259 260 } 261} 262 263sub _load_config { 264 my ($package, $params_ref) = @_; 265 266 eval 'use Config::Simple'; 267 if (!$@) { 268 # we have Config::Simple, so let's try to parse the RC file: 269 my $rcfile = $ENV{'HOME'}.'/.net-epp-simple-rc'; 270 if (-e $rcfile) { 271 my $config = Config::Simple->new($rcfile); 272 273 # if no host was defined in the constructor, use the default (if specified): 274 if (!defined($params_ref->{'host'}) && $config->param('default.default')) { 275 $params_ref->{'host'} = $config->param('default.default'); 276 } 277 278 # if no debug level was defined in the constructor, use the default (if specified): 279 if (!defined($params_ref->{'debug'}) && $config->param('default.debug')) { 280 $params_ref->{'debug'} = $config->param('default.debug'); 281 } 282 283 # grep through the file's values for settings for the selected host: 284 my %vars = $config->vars; 285 foreach my $key (grep { /^$params_ref->{'host'}\./ } keys(%vars)) { 286 my $value = $vars{$key}; 287 $key =~ s/^$params_ref->{'host'}\.//; 288 $params_ref->{$key} = $value unless (defined($params_ref->{$key})); 289 } 290 } 291 } 292} 293 294sub _connect { 295 my ($self, $login) = @_; 296 297 my %params; 298 299 $params{SSL_cipher_list} = $self->{ciphers} if (defined($self->{ssl}) && defined($self->{ciphers})); 300 301 if (defined($self->{key}) && defined($self->{cert}) && defined($self->{ssl})) { 302 $self->debug('configuring client certificate parameters'); 303 $params{SSL_key_file} = $self->{key}; 304 $params{SSL_cert_file} = $self->{cert}; 305 $params{SSL_passwd_cb} = sub { $self->{passphrase} }; 306 } 307 308 if (defined($self->{ssl}) && defined($self->{verify})) { 309 $self->debug('configuring server verification'); 310 $params{SSL_verify_mode} = 1; 311 $params{SSL_ca_file} = $self->{ca_file}; 312 $params{SSL_ca_path} = $self->{ca_path}; 313 314 } elsif (defined($self->{ssl})) { 315 $params{SSL_verify_mode} = 0; 316 317 } 318 319 $self->debug(sprintf('Attempting to connect to %s:%d', $self->{host}, $self->{port})); 320 eval { 321 $params{no_greeting} = 1; 322 $self->connect(%params); 323 }; 324 if ($@ ne '') { 325 chomp($@); 326 $@ =~ s/ at .+ line .+$//; 327 $self->debug($@); 328 $Code = COMMAND_FAILED; 329 $Error = $Message = "Error connecting: ".$@; 330 return undef; 331 332 } else { 333 $self->debug('Connected OK, retrieving greeting frame'); 334 $self->{greeting} = $self->get_frame; 335 if (ref($self->{greeting}) ne 'Net::EPP::Frame::Response') { 336 $Code = COMMAND_FAILED; 337 $Error = $Message = "Error retrieving greeting: ".$@; 338 return undef; 339 340 } else { 341 $self->debug('greeting frame retrieved OK'); 342 343 } 344 } 345 346 $self->{connected} = 1; 347 348 map { $self->debug('S: '.$_) } split(/\n/, $self->{greeting}->toString(1)); 349 350 if ($login) { 351 $self->debug('attempting login'); 352 return $self->_login; 353 354 } else { 355 return 1; 356 357 } 358} 359 360sub _login { 361 my $self = shift; 362 363 $self->debug(sprintf("Attempting to login as client ID '%s'", $self->{user})); 364 my $response = $self->request( $self->_prepare_login_frame() ); 365 366 if (!$response) { 367 $Error = $Message = "Error getting response to login request: ".$Error; 368 return undef; 369 370 } else { 371 $Code = $self->_get_response_code($response); 372 $Message = $self->_get_message($response); 373 374 $self->debug(sprintf('%04d: %s', $Code, $Message)); 375 376 if ($Code > 1999) { 377 $Error = "Error logging in (response code $Code, message $Message)"; 378 return undef; 379 380 } else { 381 $self->{authenticated} = 1; 382 return 1; 383 384 } 385 } 386} 387 388sub _get_option_uri_list { 389 my $self = shift; 390 my $tag = shift; 391 my $list = []; 392 my $elems = $self->{greeting}->getElementsByTagNameNS(EPP_XMLNS, $tag); 393 while (my $elem = $elems->shift) { 394 push @$list, $elem->firstChild->data; 395 } 396 return $list; 397} 398 399sub _prepare_login_frame { 400 my $self = shift; 401 402 $self->debug('preparing login frame'); 403 my $login = Net::EPP::Frame::Command::Login->new; 404 405 $login->clID->appendText($self->{user}); 406 $login->pw->appendText($self->{pass}); 407 $login->version->appendText($self->{greeting}->getElementsByTagNameNS(EPP_XMLNS, 'version')->shift->firstChild->data); 408 $login->lang->appendText($self->{greeting}->getElementsByTagNameNS(EPP_XMLNS, 'lang')->shift->firstChild->data); 409 410 my $objects = $self->{objects}; 411 $objects = [map { (Net::EPP::Frame::ObjectSpec->spec($_))[1] } 412 qw(contact domain host)] if $self->{stdobj}; 413 $objects = _get_option_uri_list($self,'objURI') if not $objects; 414 $login->svcs->appendTextChild('objURI', $_) for @$objects; 415 416 my $extensions = $self->{extensions}; 417 $extensions = [map { (Net::EPP::Frame::ObjectSpec->spec($_))[1] } 418 qw(secDNS)] if $self->{stdext}; 419 $extensions = _get_option_uri_list($self,'extURI') if not $extensions; 420 if (@$extensions) { 421 my $svcext = $login->createElement('svcExtension'); 422 $login->svcs->appendChild($svcext); 423 $svcext->appendTextChild('extURI', $_) for @$extensions; 424 } 425 return $login; 426} 427 428=pod 429 430=head1 Availability Checks 431 432You can do a simple C<E<lt>checkE<gt>> request for an object like so: 433 434 my $result = $epp->check_domain($domain); 435 436 my $result = $epp->check_host($host); 437 438 my $result = $epp->check_contact($contact); 439 440Each of these methods has the same profile. They will return one of the 441following: 442 443=over 444 445=item * C<undef> in the case of an error (check C<$Net::EPP::Simple::Error> and C<$Net::EPP::Simple::Code>). 446 447=item * C<0> if the object is already provisioned. 448 449=item * C<1> if the object is available. 450 451=back 452 453=cut 454 455sub check_domain { 456 my ($self, $domain) = @_; 457 return $self->_check('domain', $domain); 458} 459 460sub check_host { 461 my ($self, $host) = @_; 462 return $self->_check('host', $host); 463} 464 465sub check_contact { 466 my ($self, $contact) = @_; 467 return $self->_check('contact', $contact); 468} 469 470sub _check { 471 my ($self, $type, $identifier) = @_; 472 my $frame; 473 if ($type eq 'domain') { 474 $frame = Net::EPP::Frame::Command::Check::Domain->new; 475 $frame->addDomain($identifier); 476 477 } elsif ($type eq 'contact') { 478 $frame = Net::EPP::Frame::Command::Check::Contact->new; 479 $frame->addContact($identifier); 480 481 } elsif ($type eq 'host') { 482 $frame = Net::EPP::Frame::Command::Check::Host->new; 483 $frame->addHost($identifier); 484 485 } else { 486 $Error = "Unknown object type '$type'"; 487 return undef; 488 } 489 490 my $response = $self->_request($frame); 491 492 if (!$response) { 493 return undef; 494 495 } else { 496 $Code = $self->_get_response_code($response); 497 $Message = $self->_get_message($response); 498 499 if ($Code > 1999) { 500 $Error = $self->_get_error_message($response); 501 return undef; 502 503 } else { 504 my $xmlns = (Net::EPP::Frame::ObjectSpec->spec($type))[1]; 505 my $key; 506 if ($type eq 'domain' || $type eq 'host') { 507 $key = 'name'; 508 509 } elsif ($type eq 'contact') { 510 $key = 'id'; 511 512 } 513 return $response->getNode($xmlns, $key)->getAttribute('avail'); 514 515 } 516 } 517} 518 519=pod 520 521=head1 Retrieving Object Information 522 523You can retrieve information about an object by using one of the following: 524 525 my $info = $epp->domain_info($domain, $authInfo, $follow); 526 527 my $info = $epp->host_info($host); 528 529 my $info = $epp->contact_info($contact, $authInfo); 530 531C<Net::EPP::Simple> will construct an C<E<lt>infoE<gt>> frame and send 532it to the server, then parse the response into a simple hash ref. The 533layout of the hash ref depends on the object in question. If there is an 534error, these methods will return C<undef>, and you can then check 535C<$Net::EPP::Simple::Error> and C<$Net::EPP::Simple::Code>. 536 537If C<$authInfo> is defined, it will be sent to the server as per RFC 5385731, Section 3.1.2 and RFC 5733, Section 3.1.2. If the supplied 539authInfo code is validated by the registry, additional information will 540appear in the response. If it is invalid, you should get an error. 541 542If the C<$follow> parameter is true, then C<Net::EPP::Simple> will also 543retrieve the relevant host and contact details for a domain: instead of 544returning an object name or ID for the domain's registrant, contact 545associations, DNS servers or subordinate hosts, the values will be 546replaced with the return value from the appropriate C<host_info()> or 547C<contact_info()> command (unless there was an error, in which case the 548original object ID will be used instead). 549 550=cut 551 552sub domain_info { 553 my ($self, $domain, $authInfo, $follow) = @_; 554 my $result = $self->_info('domain', $domain, $authInfo); 555 return $result if (ref($result) ne 'HASH' || !$follow); 556 557 if (defined($result->{'ns'}) && ref($result->{'ns'}) eq 'ARRAY') { 558 for (my $i = 0 ; $i < scalar(@{$result->{'ns'}}) ; $i++) { 559 my $info = $self->host_info($result->{'ns'}->[$i]); 560 $result->{'ns'}->[$i] = $info if (ref($info) eq 'HASH'); 561 } 562 } 563 564 if (defined($result->{'hosts'}) && ref($result->{'hosts'}) eq 'ARRAY') { 565 for (my $i = 0 ; $i < scalar(@{$result->{'hosts'}}) ; $i++) { 566 my $info = $self->host_info($result->{'hosts'}->[$i]); 567 $result->{'hosts'}->[$i] = $info if (ref($info) eq 'HASH'); 568 } 569 } 570 571 my $info = $self->contact_info($result->{'registrant'}); 572 $result->{'registrant'} = $info if (ref($info) eq 'HASH'); 573 574 foreach my $type (keys(%{$result->{'contacts'}})) { 575 my $info = $self->contact_info($result->{'contacts'}->{$type}); 576 $result->{'contacts'}->{$type} = $info if (ref($info) eq 'HASH'); 577 } 578 579 return $result; 580} 581 582sub host_info { 583 my ($self, $host) = @_; 584 return $self->_info('host', $host); 585} 586 587sub contact_info { 588 my ($self, $contact, $authInfo) = @_; 589 return $self->_info('contact', $contact, $authInfo); 590} 591 592sub _info { 593 my ($self, $type, $identifier, $authInfo) = @_; 594 my $frame; 595 if ($type eq 'domain') { 596 $frame = Net::EPP::Frame::Command::Info::Domain->new; 597 $frame->setDomain($identifier); 598 599 } elsif ($type eq 'contact') { 600 $frame = Net::EPP::Frame::Command::Info::Contact->new; 601 $frame->setContact($identifier); 602 603 } elsif ($type eq 'host') { 604 $frame = Net::EPP::Frame::Command::Info::Host->new; 605 $frame->setHost($identifier); 606 607 } else { 608 $Error = "Unknown object type '$type'"; 609 return undef; 610 611 } 612 613 if (defined($authInfo) && $authInfo ne '') { 614 $self->debug('adding authInfo element to request frame'); 615 my $el = $frame->createElement((Net::EPP::Frame::ObjectSpec->spec($type))[0].':authInfo'); 616 my $pw = $frame->createElement((Net::EPP::Frame::ObjectSpec->spec($type))[0].':pw'); 617 $pw->appendChild($frame->createTextNode($authInfo)); 618 $el->appendChild($pw); 619 $frame->getNode((Net::EPP::Frame::ObjectSpec->spec($type))[1], 'info')->appendChild($el); 620 } 621 622 my $response = $self->_request($frame); 623 624 if (!$response) { 625 return undef; 626 627 } else { 628 $Code = $self->_get_response_code($response); 629 $Message = $self->_get_message($response); 630 631 if ($Code > 1999) { 632 $Error = $self->_get_error_message($response); 633 return undef; 634 635 } else { 636 return $self->parse_object_info($type, $response); 637 } 638 } 639} 640 641# An easy-to-subclass method for parsing object info 642sub parse_object_info { 643 my ($self, $type, $response) = @_; 644 645 my $infData = $response->getNode((Net::EPP::Frame::ObjectSpec->spec($type))[1], 'infData'); 646 647 if ($type eq 'domain') { 648 # secDNS extension only applies to domain objects 649 my $secinfo = $response->getNode((Net::EPP::Frame::ObjectSpec->spec('secDNS'))[1], 'infData'); 650 return $self->_domain_infData_to_hash($infData, $secinfo); 651 } elsif ($type eq 'contact') { 652 return $self->_contact_infData_to_hash($infData); 653 654 } elsif ($type eq 'host') { 655 return $self->_host_infData_to_hash($infData); 656 } else { 657 $Error = "Unknown object type '$type'"; 658 return undef; 659 } 660} 661 662sub _get_common_properties_from_infData { 663 my ($self, $infData, @extra) = @_; 664 my $hash = {}; 665 666 my @default = qw(roid clID crID crDate upID upDate trDate); 667 668 foreach my $name (@default, @extra) { 669 my $els = $infData->getElementsByLocalName($name); 670 $hash->{$name} = $els->shift->textContent if ($els->size > 0); 671 } 672 673 my $codes = $infData->getElementsByLocalName('status'); 674 while (my $code = $codes->shift) { 675 push(@{$hash->{status}}, $code->getAttribute('s')); 676 } 677 678 return $hash; 679} 680 681=pod 682 683=head2 Domain Information 684 685The hash ref returned by C<domain_info()> will usually look something 686like this: 687 688 $info = { 689 'contacts' => { 690 'admin' => 'contact-id' 691 'tech' => 'contact-id' 692 'billing' => 'contact-id' 693 }, 694 'registrant' => 'contact-id', 695 'clID' => 'registrar-id', 696 'roid' => 'tld-12345', 697 'status' => [ 698 'ok' 699 ], 700 'authInfo' => 'abc-12345', 701 'name' => 'example.tld', 702 'trDate' => '2011-01-18T11:08:03.0Z', 703 'ns' => [ 704 'ns0.example.com', 705 'ns1.example.com', 706 ], 707 'crDate' => '2011-02-16T12:06:31.0Z', 708 'exDate' => '2011-02-16T12:06:31.0Z', 709 'crID' => 'registrar-id', 710 'upDate' => '2011-08-29T04:02:12.0Z', 711 hosts => [ 712 'ns0.example.tld', 713 'ns1.example.tld', 714 ], 715 }; 716 717Members of the C<contacts> hash ref may be strings or, if there are 718multiple associations of the same type, an anonymous array of strings. 719If the server uses the "hostAttr" model instead of "hostObj", then the 720C<ns> member will look like this: 721 722 $info->{ns} = [ 723 { 724 name => 'ns0.example.com', 725 addrs => [ 726 type => 'v4', 727 addr => '10.0.0.1', 728 ], 729 }, 730 { 731 name => 'ns1.example.com', 732 addrs => [ 733 type => 'v4', 734 addr => '10.0.0.2', 735 ], 736 }, 737 ]; 738 739Note that there may be multiple members in the C<addrs> section and that 740the C<type> attribute is optional. 741 742=cut 743 744sub _domain_infData_to_hash { 745 my ($self, $infData, $secinfo) = @_; 746 747 my $hash = $self->_get_common_properties_from_infData($infData, 'registrant', 'name', 'exDate'); 748 749 my $contacts = $infData->getElementsByLocalName('contact'); 750 while (my $contact = $contacts->shift) { 751 my $type = $contact->getAttribute('type'); 752 my $id = $contact->textContent; 753 754 if (ref($hash->{contacts}->{$type}) eq 'STRING') { 755 $hash->{contacts}->{$type} = [ $hash->{contacts}->{$type}, $id ]; 756 757 } elsif (ref($hash->{contacts}->{$type}) eq 'ARRAY') { 758 push(@{$hash->{contacts}->{$type}}, $id); 759 760 } else { 761 $hash->{contacts}->{$type} = $id; 762 763 } 764 765 } 766 767 my $ns = $infData->getElementsByLocalName('ns'); 768 if ($ns->size == 1) { 769 my $el = $ns->shift; 770 my $hostObjs = $el->getElementsByLocalName('hostObj'); 771 while (my $hostObj = $hostObjs->shift) { 772 push(@{$hash->{ns}}, $hostObj->textContent); 773 } 774 775 my $hostAttrs = $el->getElementsByLocalName('hostAttr'); 776 while (my $hostAttr = $hostAttrs->shift) { 777 my $host = {}; 778 $host->{name} = $hostAttr->getElementsByLocalName('hostName')->shift->textContent; 779 my $addrs = $hostAttr->getElementsByLocalName('hostAddr'); 780 while (my $addr = $addrs->shift) { 781 push(@{$host->{addrs}}, { version => $addr->getAttribute('ip'), addr => $addr->textContent }); 782 } 783 push(@{$hash->{ns}}, $host); 784 } 785 } 786 787 my $hosts = $infData->getElementsByLocalName('host'); 788 while (my $host = $hosts->shift) { 789 push(@{$hash->{hosts}}, $host->textContent); 790 } 791 792 my $auths = $infData->getElementsByLocalName('authInfo'); 793 if ($auths->size == 1) { 794 my $authInfo = $auths->shift; 795 my $pw = $authInfo->getElementsByLocalName('pw'); 796 $hash->{authInfo} = $pw->shift->textContent if ($pw->size == 1); 797 } 798 799 if (defined $secinfo) { 800 if (my $maxSigLife = $secinfo->getElementsByLocalName('maxSigLife')) { 801 $hash->{maxSigLife} = $maxSigLife->shift->textContent; 802 } 803 my $dslist = $secinfo->getElementsByTagName('secDNS:dsData'); 804 while (my $ds = $dslist->shift) { 805 my @ds = map { $ds->getElementsByLocalName($_)->string_value() } 806 qw(keyTag alg digestType digest); 807 push @{ $hash->{DS} }, "@ds"; 808 } 809 my $keylist = $secinfo->getElementsByLocalName('keyData'); 810 while (my $key = $keylist->shift) { 811 my @key = map { $key->getElementsByLocalName($_)->string_value() } 812 qw(flags protocol alg pubKey); 813 push @{ $hash->{DNSKEY} }, "@key"; 814 } 815 } 816 817 return $hash; 818} 819 820 821=pod 822 823=head2 Host Information 824 825The hash ref returned by C<host_info()> will usually look something like 826this: 827 828 $info = { 829 'crDate' => '2011-09-17T15:38:56.0Z', 830 'clID' => 'registrar-id', 831 'crID' => 'registrar-id', 832 'roid' => 'tld-12345', 833 'status' => [ 834 'linked', 835 'serverDeleteProhibited', 836 ], 837 'name' => 'ns0.example.tld', 838 'addrs' => [ 839 { 840 'version' => 'v4', 841 'addr' => '10.0.0.1' 842 } 843 ] 844 }; 845 846Note that hosts may have multiple addresses, and that C<version> is 847optional. 848 849=cut 850 851sub _host_infData_to_hash { 852 my ($self, $infData) = @_; 853 854 my $hash = $self->_get_common_properties_from_infData($infData, 'name'); 855 856 my $addrs = $infData->getElementsByLocalName('addr'); 857 while (my $addr = $addrs->shift) { 858 push(@{$hash->{addrs}}, { version => $addr->getAttribute('ip'), addr => $addr->textContent }); 859 } 860 861 return $hash; 862} 863 864=pod 865 866=head2 Contact Information 867 868The hash ref returned by C<contact_info()> will usually look something 869like this: 870 871 $VAR1 = { 872 'id' => 'contact-id', 873 'postalInfo' => { 874 'int' => { 875 'name' => 'John Doe', 876 'org' => 'Example Inc.', 877 'addr' => { 878 'street' => [ 879 '123 Example Dr.' 880 'Suite 100' 881 ], 882 'city' => 'Dulles', 883 'sp' => 'VA', 884 'pc' => '20116-6503' 885 'cc' => 'US', 886 } 887 } 888 }, 889 'clID' => 'registrar-id', 890 'roid' => 'CNIC-HA321983', 891 'status' => [ 892 'linked', 893 'serverDeleteProhibited' 894 ], 895 'voice' => '+1.7035555555x1234', 896 'fax' => '+1.7035555556', 897 'email' => 'jdoe@example.com', 898 'crDate' => '2011-09-23T03:51:29.0Z', 899 'upDate' => '1999-11-30T00:00:00.0Z' 900 }; 901 902There may be up to two members of the C<postalInfo> hash, corresponding 903to the C<int> and C<loc> internationalised and localised types. 904 905=cut 906 907sub _contact_infData_to_hash { 908 my ($self, $infData) = @_; 909 910 my $hash = $self->_get_common_properties_from_infData($infData, 'email', 'id'); 911 912 # remove this as it gets in the way: 913 my $els = $infData->getElementsByLocalName('disclose'); 914 if ($els->size > 0) { 915 while (my $el = $els->shift) { 916 $el->parentNode->removeChild($el); 917 } 918 } 919 920 foreach my $name ('voice', 'fax') { 921 my $els = $infData->getElementsByLocalName($name); 922 if (defined($els) && $els->size == 1) { 923 my $el = $els->shift; 924 if (defined($el)) { 925 $hash->{$name} = $el->textContent; 926 $hash->{$name} .= 'x'.$el->getAttribute('x') if (defined($el->getAttribute('x')) && $el->getAttribute('x') ne ''); 927 } 928 } 929 } 930 931 my $postalInfo = $infData->getElementsByLocalName('postalInfo'); 932 while (my $info = $postalInfo->shift) { 933 my $ref = {}; 934 935 foreach my $name (qw(name org)) { 936 my $els = $info->getElementsByLocalName($name); 937 $ref->{$name} = $els->shift->textContent if ($els->size == 1); 938 } 939 940 my $addrs = $info->getElementsByLocalName('addr'); 941 if ($addrs->size == 1) { 942 my $addr = $addrs->shift; 943 foreach my $child ($addr->childNodes) { 944 next if (XML::LibXML::XML_ELEMENT_NODE != $child->nodeType); 945 if ($child->localName eq 'street') { 946 push(@{$ref->{addr}->{$child->localName}}, $child->textContent); 947 948 } else { 949 $ref->{addr}->{$child->localName} = $child->textContent; 950 951 } 952 } 953 } 954 955 $hash->{postalInfo}->{$info->getAttribute('type')} = $ref; 956 } 957 958 my $auths = $infData->getElementsByLocalName('authInfo'); 959 if ($auths->size == 1) { 960 my $authInfo = $auths->shift; 961 my $pw = $authInfo->getElementsByLocalName('pw'); 962 $hash->{authInfo} = $pw->shift->textContent if ($pw->size == 1); 963 } 964 965 return $hash; 966} 967 968=pod 969 970=head1 Object Transfers 971 972The EPP C<E<lt>transferE<gt>> command suppots five different operations: 973query, request, cancel, approve, and reject. C<Net::EPP::Simple> makes 974these available using the following methods: 975 976 # For domain objects: 977 978 $epp->domain_transfer_query($domain); 979 $epp->domain_transfer_cancel($domain); 980 $epp->domain_transfer_request($domain, $authInfo, $period); 981 $epp->domain_transfer_approve($domain); 982 $epp->domain_transfer_reject($domain); 983 984 # For contact objects: 985 986 $epp->contact_transfer_query($contact); 987 $epp->contact_transfer_cancel($contact); 988 $epp->contact_transfer_request($contact, $authInfo); 989 $epp->contact_transfer_approve($contact); 990 $epp->contact_transfer_reject($contact); 991 992Most of these methods will just set the value of C<$Net::EPP::Simple::Code> 993and return either true or false. However, the C<domain_transfer_request()>, 994C<domain_transfer_query()>, C<contact_transfer_request()> and C<contact_transfer_query()> 995methods will return a hash ref that looks like this: 996 997 my $trnData = { 998 'name' => 'example.tld', 999 'reID' => 'losing-registrar', 1000 'acDate' => '2011-12-04T12:24:53.0Z', 1001 'acID' => 'gaining-registrar', 1002 'reDate' => '2011-11-29T12:24:53.0Z', 1003 'trStatus' => 'pending' 1004 }; 1005 1006=cut 1007 1008sub _transfer_request { 1009 my ($self, $op, $type, $identifier, $authInfo, $period) = @_; 1010 1011 my $class = sprintf('Net::EPP::Frame::Command::Transfer::%s', ucfirst(lc($type))); 1012 1013 my $frame; 1014 eval("\$frame = $class->new"); 1015 if ($@ || ref($frame) ne $class) { 1016 $Error = "Error building request frame: $@"; 1017 $Code = COMMAND_FAILED; 1018 return undef; 1019 1020 } else { 1021 $frame->setOp($op); 1022 if ($type eq 'domain') { 1023 $frame->setDomain($identifier); 1024 $frame->setPeriod(int($period)) if ($op eq 'request'); 1025 1026 } elsif ($type eq 'contact') { 1027 $frame->setContact($identifier); 1028 1029 } 1030 1031 if ($op eq 'request' || $op eq 'query') { 1032 $frame->setAuthInfo($authInfo) if ($authInfo ne ''); 1033 } 1034 1035 } 1036 1037 my $response = $self->_request($frame); 1038 1039 1040 if (!$response) { 1041 return undef; 1042 1043 } else { 1044 $Code = $self->_get_response_code($response); 1045 $Message = $self->_get_message($response); 1046 1047 if ($Code > 1999) { 1048 $Error = $response->msg; 1049 return undef; 1050 1051 } elsif ($op eq 'query' || $op eq 'request') { 1052 my $trnData = $response->getElementsByLocalName('trnData')->shift; 1053 my $hash = {}; 1054 foreach my $child ($trnData->childNodes) { 1055 $hash->{$child->localName} = $child->textContent; 1056 } 1057 1058 return $hash; 1059 1060 } else { 1061 return 1; 1062 1063 } 1064 } 1065} 1066 1067sub domain_transfer_query { 1068 return $_[0]->_transfer_request('query', 'domain', $_[1]); 1069} 1070 1071sub domain_transfer_cancel { 1072 return $_[0]->_transfer_request('cancel', 'domain', $_[1]); 1073} 1074 1075sub domain_transfer_request { 1076 return $_[0]->_transfer_request('request', 'domain', $_[1], $_[2], $_[3]); 1077} 1078 1079sub domain_transfer_approve { 1080 return $_[0]->_transfer_request('approve', 'domain', $_[1]); 1081} 1082 1083sub domain_transfer_reject { 1084 return $_[0]->_transfer_request('reject', 'domain', $_[1]); 1085} 1086 1087sub contact_transfer_query { 1088 return $_[0]->_transfer_request('query', 'contact', $_[1]); 1089} 1090 1091sub contact_transfer_cancel { 1092 return $_[0]->_transfer_request('cancel', 'contact', $_[1]); 1093} 1094 1095sub contact_transfer_request { 1096 return $_[0]->_transfer_request('request', 'contact', $_[1], $_[2]); 1097} 1098 1099sub contact_transfer_approve { 1100 return $_[0]->_transfer_request('approve', 'contact', $_[1]); 1101} 1102 1103sub contact_transfer_reject { 1104 return $_[0]->_transfer_request('reject', 'contact', $_[1]); 1105} 1106 1107=pod 1108 1109=head1 Creating Objects 1110 1111The following methods can be used to create a new object at the server: 1112 1113 $epp->create_domain($domain); 1114 $epp->create_host($host); 1115 $epp->create_contact($contact); 1116 1117The argument for these methods is a hash ref of the same format as that 1118returned by the info methods above. As a result, cloning an existing 1119object is as simple as the following: 1120 1121 my $info = $epp->contact_info($contact); 1122 1123 # set a new contact ID to avoid clashing with the existing object 1124 $info->{id} = $new_contact; 1125 1126 # randomize authInfo: 1127 $info->{authInfo} = $random_string; 1128 1129 $epp->create_contact($info); 1130 1131C<Net::EPP::Simple> will ignore object properties that it does not recognise, 1132and those properties (such as server-managed status codes) that clients are 1133not permitted to set. 1134 1135=head2 Creating New Domains 1136 1137When creating a new domain object, you may also specify a C<period> key, like so: 1138 1139 my $domain = { 1140 'name' => 'example.tld', 1141 'period' => 2, 1142 'registrant' => 'contact-id', 1143 'contacts' => { 1144 'tech' => 'contact-id', 1145 'admin' => 'contact-id', 1146 'billing' => 'contact-id', 1147 }, 1148 'status' => [ 1149 'clientTransferProhibited', 1150 ], 1151 'ns' => { 1152 'ns0.example.com', 1153 'ns1.example.com', 1154 }, 1155 }; 1156 1157 $epp->create_domain($domain); 1158 1159The C<period> key is assumed to be in years rather than months. C<Net::EPP::Simple> 1160assumes the registry uses the host object model rather than the host attribute model. 1161 1162=cut 1163 1164sub create_domain { 1165 my ($self, $domain) = @_; 1166 1167 return $self->_get_response_result( 1168 $self->_request( 1169 $self->_prepare_create_domain_frame($domain) 1170 ) 1171 ); 1172} 1173 1174sub _prepare_create_domain_frame { 1175 my ($self, $domain) = @_; 1176 1177 my $frame = Net::EPP::Frame::Command::Create::Domain->new; 1178 $frame->setDomain($domain->{'name'}); 1179 $frame->setPeriod($domain->{'period'}); 1180 $frame->setNS(@{$domain->{'ns'}}) if $domain->{'ns'} and @{$domain->{'ns'}}; 1181 $frame->setRegistrant($domain->{'registrant'}); 1182 $frame->setContacts($domain->{'contacts'}); 1183 $frame->setAuthInfo($domain->{authInfo}) if ($domain->{authInfo} ne ''); 1184 return $frame; 1185} 1186 1187=head2 Creating Hosts 1188 1189 my $host = { 1190 name => 'ns1.example.tld', 1191 addrs => [ 1192 { ip => '123.45.67.89', version => 'v4' }, 1193 { ip => '98.76.54.32', version => 'v4' }, 1194 ], 1195 }; 1196 $epp->create_host($host); 1197 1198=cut 1199 1200sub create_host { 1201 my ($self, $host) = @_; 1202 1203 return $self->_get_response_result( 1204 $self->_request( 1205 $self->_prepare_create_host_frame($host) 1206 ) 1207 ); 1208} 1209 1210sub _prepare_create_host_frame { 1211 my ($self, $host) = @_; 1212 1213 my $frame = Net::EPP::Frame::Command::Create::Host->new; 1214 $frame->setHost($host->{name}); 1215 $frame->setAddr(@{$host->{addrs}}); 1216 return $frame; 1217} 1218 1219sub create_contact { 1220 my ($self, $contact) = @_; 1221 1222 return $self->_get_response_result( 1223 $self->_request( 1224 $self->_prepare_create_contact_frame($contact) 1225 ) 1226 ); 1227} 1228 1229 1230sub _prepare_create_contact_frame { 1231 my ($self, $contact) = @_; 1232 1233 my $frame = Net::EPP::Frame::Command::Create::Contact->new; 1234 1235 $frame->setContact($contact->{id}); 1236 1237 if (ref($contact->{postalInfo}) eq 'HASH') { 1238 foreach my $type (keys(%{$contact->{postalInfo}})) { 1239 $frame->addPostalInfo( 1240 $type, 1241 $contact->{postalInfo}->{$type}->{name}, 1242 $contact->{postalInfo}->{$type}->{org}, 1243 $contact->{postalInfo}->{$type}->{addr} 1244 ); 1245 } 1246 } 1247 1248 $frame->setVoice($contact->{voice}) if ($contact->{voice} ne ''); 1249 $frame->setFax($contact->{fax}) if ($contact->{fax} ne ''); 1250 $frame->setEmail($contact->{email}); 1251 $frame->setAuthInfo($contact->{authInfo}) if ($contact->{authInfo} ne ''); 1252 1253 if (ref($contact->{status}) eq 'ARRAY') { 1254 foreach my $status (grep { /^client/ } @{$contact->{status}}) { 1255 $frame->appendStatus($status); 1256 } 1257 } 1258 return $frame; 1259} 1260 1261 1262# Process response code and return result 1263sub _get_response_result { 1264 my ($self, $response) = @_; 1265 1266 return undef if !$response; 1267 1268 # If there was a response... 1269 $Code = $self->_get_response_code($response); 1270 $Message = $self->_get_message($response); 1271 if ($Code > 1999) { 1272 $Error = $response->msg; 1273 return undef; 1274 } 1275 return 1; 1276} 1277 1278 1279=head1 Updating Objects 1280 1281The following methods can be used to update an object at the server: 1282 1283 $epp->update_domain($domain); 1284 $epp->update_host($host); 1285 $epp->update_contact($contact); 1286 1287Each of these methods has the same profile. They will return one of the following: 1288 1289=over 1290 1291=item * undef in the case of an error (check C<$Net::EPP::Simple::Error> and C<$Net::EPP::Simple::Code>). 1292 1293=item * 1 if the update request was accepted. 1294 1295=back 1296 1297You may wish to check the value of $Net::EPP::Simple::Code to determine whether the response code was 1000 (OK) or 1001 (action pending). 1298 1299=cut 1300 1301 1302=head2 Updating Domains 1303 1304Use update_domain() method to update domains' data. 1305 1306The update info parameter may look like: 1307$update_info = { 1308 name => $domain, 1309 chg => { 1310 registrant => $new_registrant_id, 1311 authInfo => $new_domain_password, 1312 }, 1313 add => { 1314 # DNS info with "hostObj" or "hostAttr" model, see create_domain() 1315 ns => [ ns1.example.com ns2.example.com ], 1316 contacts => { 1317 tech => 'contact-id', 1318 billing => 'contact-id', 1319 admin => 'contact-id', 1320 }, 1321 1322 # Status info, simple form: 1323 status => [ qw/ clientUpdateProhibited clientHold / ], 1324 1325 # Status info may be in more detailed form: 1326 # status => { 1327 # clientUpdateProbhibited => 'Avoid accidental change', 1328 # clientHold => 'This domain is not delegated', 1329 # }, 1330 }, 1331 rem => { 1332 ns => [ ... ], 1333 contacts => { 1334 tech => 'old_tech_id', 1335 billing => 'old_billing_id', 1336 admin => 'old_admin_id', 1337 }, 1338 status => [ qw/ clientTransferProhibited ... / ], 1339 }, 1340} 1341 1342All fields except 'name' in $update_info hash are optional. 1343 1344=cut 1345 1346sub update_domain { 1347 my ($self, $domain) = @_; 1348 return $self->_update('domain', $domain); 1349} 1350 1351=head2 Updating Contacts 1352 1353Use update_contact() method to update contact's data. 1354 1355The $update_info for contacts may look like this: 1356 1357$update_info = { 1358 id => $contact_id, 1359 add => { 1360 status => [ qw/ clientDeleteProhibited / ], 1361 # OR 1362 # status => { 1363 # clientDeleteProhibited => 'Avoid accidental removal', 1364 # }, 1365 }, 1366 rem => { 1367 status => [ qw/ clientUpdateProhibited / ], 1368 }, 1369 chg => { 1370 postalInfo => { 1371 int => { 1372 name => 'John Doe', 1373 org => 'Example Inc.', 1374 addr => { 1375 street => [ 1376 '123 Example Dr.' 1377 'Suite 100' 1378 ], 1379 city => 'Dulles', 1380 sp => 'VA', 1381 pc => '20116-6503' 1382 cc => 'US', 1383 }, 1384 }, 1385 }, 1386 voice => '+1.7035555555x1234', 1387 fax => '+1.7035555556', 1388 email => 'jdoe@example.com', 1389 authInfo => 'new-contact-password', 1390 }, 1391} 1392 1393All fields except 'id' in $update_info hash are optional. 1394 1395=cut 1396 1397sub update_contact { 1398 my ($self, $contact) = @_; 1399 return $self->_update('contact', $contact); 1400} 1401 1402=head2 Updating Hosts 1403 1404Use update_host() method to update EPP hosts. 1405 1406The $update_info for hosts may look like this: 1407 1408$update_info = { 1409 name => 'ns1.example.com', 1410 add => { 1411 status => [ qw/ clientDeleteProhibited / ], 1412 # OR 1413 # status => { 1414 # clientDeleteProhibited => 'Avoid accidental removal', 1415 # }, 1416 1417 addrs => [ 1418 { ip => '123.45.67.89', version => 'v4' }, 1419 { ip => '98.76.54.32', version => 'v4' }, 1420 ], 1421 }, 1422 rem => { 1423 status => [ qw/ clientUpdateProhibited / ], 1424 addrs => [ 1425 { ip => '1.2.3.4', version => 'v4' }, 1426 { ip => '5.6.7.8', version => 'v4' }, 1427 ], 1428 }, 1429 chg => { 1430 name => 'ns2.example.com', 1431 }, 1432} 1433 1434All fields except first 'name' in $update_info hash are optional. 1435 1436=cut 1437 1438sub update_host { 1439 my ($self, $host) = @_; 1440 return $self->_update('host', $host); 1441} 1442 1443 1444# Update domain/contact/host information 1445sub _update { 1446 my ($self, $type, $info) = @_; 1447 1448 my %frame_generator = ( 1449 'domain' => \&_generate_update_domain_frame, 1450 'contact' => \&_generate_update_contact_frame, 1451 'host' => \&_generate_update_host_frame, 1452 ); 1453 1454 if ( !exists $frame_generator{$type} ) { 1455 $Error = "Unknown object type: '$type'"; 1456 return undef; 1457 } 1458 1459 my $generator = $frame_generator{$type}; 1460 my $frame = $self->$generator($info); 1461 return $self->_get_response_result( $self->request($frame) ); 1462} 1463 1464 1465sub _generate_update_domain_frame { 1466 my ($self, $info) = @_; 1467 1468 my $frame = Net::EPP::Frame::Command::Update::Domain->new; 1469 $frame->setDomain( $info->{name} ); 1470 1471 # 'add' element 1472 if ( exists $info->{add} && ref $info->{add} eq 'HASH' ) { 1473 1474 my $add = $info->{add}; 1475 1476 # Add DNS 1477 if ( exists $add->{ns} && ref $add->{ns} eq 'ARRAY' ) { 1478 $frame->addNS( @{ $add->{ns} } ); 1479 } 1480 1481 # Add contacts 1482 if ( exists $add->{contacts} && ref $add->{contacts} eq 'HASH' ) { 1483 1484 my $contacts = $add->{contacts}; 1485 foreach my $type ( keys %{ $contacts } ) { 1486 $frame->addContact( $type, $contacts->{$type} ); 1487 } 1488 } 1489 1490 # Add status info 1491 if ( exists $add->{status} && ref $add->{status} ) { 1492 if ( ref $add->{status} eq 'HASH' ) { 1493 while ( my ($type, $info) = each %{ $add->{status} } ) { 1494 $frame->addStatus($type, $info); 1495 } 1496 } 1497 elsif ( ref $add->{status} eq 'ARRAY' ) { 1498 $frame->addStatus($_) for @{ $add->{status} }; 1499 } 1500 } 1501 } 1502 1503 # 'rem' element 1504 if ( exists $info->{rem} && ref $info->{rem} eq 'HASH' ) { 1505 1506 my $rem = $info->{rem}; 1507 1508 # DNS 1509 if ( exists $rem->{ns} && ref $rem->{ns} eq 'ARRAY' ) { 1510 $frame->remNS( @{ $rem->{ns} } ); 1511 } 1512 1513 # Contacts 1514 if ( exists $rem->{contacts} && ref $rem->{contacts} eq 'HASH' ) { 1515 my $contacts = $rem->{contacts}; 1516 1517 foreach my $type ( keys %{ $contacts } ) { 1518 $frame->remContact( $type, $contacts->{$type} ); 1519 } 1520 } 1521 1522 # Status info 1523 if ( exists $rem->{status} && ref $rem->{status} eq 'ARRAY' ) { 1524 $frame->remStatus($_) for @{ $rem->{status} }; 1525 } 1526 } 1527 1528 # 'chg' element 1529 if ( exists $info->{chg} && ref $info->{chg} eq 'HASH' ) { 1530 1531 my $chg = $info->{chg}; 1532 1533 if ( defined $chg->{registrant} ) { 1534 $frame->chgRegistrant( $chg->{registrant} ); 1535 } 1536 1537 if ( defined $chg->{authInfo} ) { 1538 $frame->chgAuthInfo( $chg->{authInfo} ); 1539 } 1540 } 1541 1542 return $frame; 1543} 1544 1545 1546sub _generate_update_contact_frame { 1547 my ($self, $info) = @_; 1548 1549 my $frame = Net::EPP::Frame::Command::Update::Contact->new; 1550 $frame->setContact( $info->{id} ); 1551 1552 # Add 1553 if ( exists $info->{add} && ref $info->{add} eq 'HASH' ) { 1554 my $add = $info->{add}; 1555 1556 if ( exists $add->{status} && ref $add->{status} ) { 1557 if ( ref $add->{status} eq 'HASH' ) { 1558 while ( my ($type, $info) = each %{ $add->{status} } ) { 1559 $frame->addStatus($type, $info); 1560 } 1561 } 1562 elsif ( ref $add->{status} eq 'ARRAY' ) { 1563 $frame->addStatus($_) for @{ $add->{status} }; 1564 } 1565 } 1566 } 1567 1568 # Remove 1569 if ( exists $info->{rem} && ref $info->{rem} eq 'HASH' ) { 1570 1571 my $rem = $info->{rem}; 1572 1573 if ( exists $rem->{status} && ref $rem->{status} eq 'ARRAY' ) { 1574 $frame->remStatus($_) for @{ $rem->{status} }; 1575 } 1576 } 1577 1578 # Change 1579 if ( exists $info->{chg} && ref $info->{chg} eq 'HASH' ) { 1580 1581 my $chg = $info->{chg}; 1582 1583 # Change postal info 1584 if ( ref $chg->{postalInfo} eq 'HASH' ) { 1585 foreach my $type ( keys %{ $chg->{postalInfo} } ) { 1586 $frame->chgPostalInfo( 1587 $type, 1588 $chg->{postalInfo}->{$type}->{name}, 1589 $chg->{postalInfo}->{$type}->{org}, 1590 $chg->{postalInfo}->{$type}->{addr} 1591 ); 1592 } 1593 } 1594 1595 # Change voice / fax / email 1596 for my $contact_type ( qw/ voice fax email / ) { 1597 if ( defined $chg->{$contact_type} ) { 1598 my $el = $frame->createElement("contact:$contact_type"); 1599 $el->appendText( $chg->{$contact_type} ); 1600 $frame->chg->appendChild($el); 1601 } 1602 } 1603 1604 # Change auth info 1605 if ( $chg->{authInfo} ) { 1606 $frame->chgAuthInfo( $chg->{authInfo} ); 1607 } 1608 1609 # 'disclose' option is still unimplemented 1610 } 1611 1612 return $frame; 1613} 1614 1615sub _generate_update_host_frame { 1616 my ($self, $info) = @_; 1617 1618 my $frame = Net::EPP::Frame::Command::Update::Host->new; 1619 $frame->setHost($info->{name}); 1620 1621 if ( exists $info->{add} && ref $info->{add} eq 'HASH' ) { 1622 my $add = $info->{add}; 1623 # Process addresses 1624 if ( exists $add->{addrs} && ref $add->{addrs} eq 'ARRAY' ) { 1625 $frame->addAddr( @{ $add->{addrs} } ); 1626 } 1627 # Process statuses 1628 if ( exists $add->{status} && ref $add->{status} ) { 1629 if ( ref $add->{status} eq 'HASH' ) { 1630 while ( my ($type, $info) = each %{ $add->{status} } ) { 1631 $frame->addStatus($type, $info); 1632 } 1633 } 1634 elsif ( ref $add->{status} eq 'ARRAY' ) { 1635 $frame->addStatus($_) for @{ $add->{status} }; 1636 } 1637 } 1638 } 1639 1640 if ( exists $info->{rem} && ref $info->{rem} eq 'HASH' ) { 1641 my $rem = $info->{rem}; 1642 # Process addresses 1643 if ( exists $rem->{addrs} && ref $rem->{addrs} eq 'ARRAY' ) { 1644 $frame->remAddr( @{ $rem->{addrs} } ); 1645 } 1646 # Process statuses 1647 if ( exists $rem->{status} && ref $rem->{status} ) { 1648 if ( ref $rem->{status} eq 'HASH' ) { 1649 while ( my ($type, $info) = each %{ $rem->{status} } ) { 1650 $frame->remStatus($type, $info); 1651 } 1652 } 1653 elsif ( ref $rem->{status} eq 'ARRAY' ) { 1654 $frame->remStatus($_) for @{ $rem->{status} }; 1655 } 1656 } 1657 } 1658 1659 if ( exists $info->{chg} && ref $info->{chg} eq 'HASH' ) { 1660 if ( $info->{chg}->{name} ) { 1661 $frame->chgName( $info->{chg}->{name} ); 1662 } 1663 } 1664 1665 return $frame; 1666} 1667 1668 1669=pod 1670 1671=head1 Deleting Objects 1672 1673The following methods can be used to delete an object at the server: 1674 1675 $epp->delete_domain($domain); 1676 $epp->delete_host($host); 1677 $epp->delete_contact($contact); 1678 1679Each of these methods has the same profile. They will return one of the following: 1680 1681=over 1682 1683=item * undef in the case of an error (check C<$Net::EPP::Simple::Error> and C<$Net::EPP::Simple::Code>). 1684 1685=item * 1 if the deletion request was accepted. 1686 1687=back 1688 1689You may wish to check the value of $Net::EPP::Simple::Code to determine whether the response code was 1000 (OK) or 1001 (action pending). 1690 1691=cut 1692 1693sub delete_domain { 1694 my ($self, $domain) = @_; 1695 return $self->_delete('domain', $domain); 1696} 1697 1698sub delete_host { 1699 my ($self, $host) = @_; 1700 return $self->_delete('host', $host); 1701} 1702 1703sub delete_contact { 1704 my ($self, $contact) = @_; 1705 return $self->_delete('contact', $contact); 1706} 1707 1708sub _delete { 1709 my ($self, $type, $identifier) = @_; 1710 my $frame; 1711 if ($type eq 'domain') { 1712 $frame = Net::EPP::Frame::Command::Delete::Domain->new; 1713 $frame->setDomain($identifier); 1714 1715 } elsif ($type eq 'contact') { 1716 $frame = Net::EPP::Frame::Command::Delete::Contact->new; 1717 $frame->setContact($identifier); 1718 1719 } elsif ($type eq 'host') { 1720 $frame = Net::EPP::Frame::Command::Delete::Host->new; 1721 $frame->setHost($identifier); 1722 1723 } else { 1724 $Error = "Unknown object type '$type'"; 1725 return undef; 1726 1727 } 1728 1729 my $response = $self->_request($frame); 1730 1731 1732 if (!$response) { 1733 return undef; 1734 1735 } else { 1736 $Code = $self->_get_response_code($response); 1737 $Message = $self->_get_message($response); 1738 1739 if ($Code > 1999) { 1740 $Error = $self->_get_error_message($response); 1741 return undef; 1742 1743 } else { 1744 return 1; 1745 1746 } 1747 } 1748} 1749 1750=head1 Domain Renewal 1751 1752You can extend the validity period of the domain object by issuing a 1753renew_domain() command. 1754 1755 my $result = $epp->renew_domain({ 1756 name => 'example.com', 1757 cur_exp_date => '2011-02-05', # current expiration date 1758 period => 2, # prolongation period in years 1759 }); 1760 1761Return value is C<1> on success and C<undef> on error. 1762In the case of error C<$Net::EPP::Simple::Error> contains the appropriate 1763error message. 1764 1765=cut 1766 1767sub renew_domain { 1768 my ($self, $info) = @_; 1769 1770 return $self->_get_response_result( 1771 $self->request( 1772 $self->_generate_renew_domain_frame($info) 1773 ) 1774 ); 1775} 1776 1777sub _generate_renew_domain_frame { 1778 my ($self, $info) = @_; 1779 1780 my $frame = Net::EPP::Frame::Command::Renew::Domain->new; 1781 $frame->setDomain( $info->{name} ); 1782 $frame->setCurExpDate( $info->{cur_exp_date} ); 1783 $frame->setPeriod( $info->{period} ) if $info->{period}; 1784 1785 return $frame; 1786} 1787 1788=pod 1789 1790=head1 Miscellaneous Methods 1791 1792=cut 1793 1794sub error { $Error } 1795 1796sub code { $Code } 1797 1798sub message { $Message } 1799 1800=pod 1801 1802 my $greeting = $epp->greeting; 1803 1804Returns the a C<Net::EPP::Frame::Greeting> object representing the greeting returned by the server. 1805 1806=cut 1807 1808sub greeting { $_[0]->{greeting} } 1809 1810=pod 1811 1812 $epp->ping; 1813 1814Checks that the connection is up by sending a C<E<lt>helloE<gt>> to the server. Returns false if no 1815response is received. 1816 1817=cut 1818 1819sub ping { 1820 my $self = shift; 1821 my $hello = Net::EPP::Frame::Hello->new; 1822 my $response = $self->request($hello); 1823 1824 return (UNIVERSAL::isa($response, 'XML::LibXML::Document') ? 1 : undef); 1825} 1826 1827sub _request { 1828 my ($self, $frame) = @_; 1829 1830 if ($self->{reconnect} > 0) { 1831 $self->debug("reconnect is $self->{reconnect}, pinging"); 1832 if (!$self->ping) { 1833 $self->debug('connection seems dead, trying to reconnect'); 1834 for (1..$self->{reconnect}) { 1835 $self->debug("attempt #$_"); 1836 if ($self->_connect) { 1837 $self->debug("attempt #$_ succeeded"); 1838 return $self->request($frame); 1839 1840 } else { 1841 $self->debug("attempt #$_ failed, sleeping"); 1842 sleep($self->{timeout}); 1843 1844 } 1845 } 1846 $self->debug('unable to reconnect!'); 1847 return undef; 1848 1849 } else { 1850 $self->debug("Connection is up, sending frame"); 1851 return $self->request($frame); 1852 1853 } 1854 1855 } else { 1856 return $self->request($frame); 1857 1858 } 1859} 1860 1861=pod 1862 1863=head1 Overridden Methods From C<Net::EPP::Client> 1864 1865C<Net::EPP::Simple> overrides some methods inherited from 1866C<Net::EPP::Client>. These are described below: 1867 1868=head2 The C<request()> Method 1869 1870C<Net::EPP::Simple> overrides this method so it can automatically populate 1871the C<E<lt>clTRIDE<gt>> element with a unique string. It then passes the 1872frame back up to C<Net::EPP::Client>. 1873 1874=cut 1875 1876sub request { 1877 my ($self, $frame) = @_; 1878 # Make sure we start with blank variables 1879 $Code = undef; 1880 $Error = ''; 1881 $Message = ''; 1882 1883 $frame->clTRID->appendText(sha1_hex(ref($self).time().$$)) if (UNIVERSAL::isa($frame, 'Net::EPP::Frame::Command')); 1884 1885 $self->debug(sprintf('sending a %s to the server', ref($frame) || (-e $frame ? 'file' : 'string'))); 1886 if (UNIVERSAL::isa($frame, 'XML::LibXML::Document')) { 1887 map { $self->debug('C: '.$_) } split(/\n/, $frame->toString(2)); 1888 1889 } else { 1890 map { $self->debug('C: '.$_) } split(/\n/, $frame); 1891 1892 } 1893 1894 my $response = $self->SUPER::request($frame); 1895 1896 map { $self->debug('S: '.$_) } split(/\n/, $response->toString(2)) if (UNIVERSAL::isa($response, 'XML::LibXML::Document')); 1897 1898 return $response; 1899} 1900 1901=pod 1902 1903=head2 The C<get_frame()> Method 1904 1905C<Net::EPP::Simple> overrides this method so it can catch timeouts and 1906network errors. If such an error occurs it will return C<undef>. 1907 1908=cut 1909 1910sub get_frame { 1911 my $self = shift; 1912 my $frame; 1913 $self->debug(sprintf('reading frame, waiting %d seconds before timeout', $self->{timeout})); 1914 eval { 1915 local $SIG{ALRM} = sub { die 'timeout' }; 1916 $self->debug('setting timeout alarm for receiving frame'); 1917 alarm($self->{timeout}); 1918 $frame = $self->SUPER::get_frame(); 1919 $self->debug('unsetting timeout alarm after successful receive'); 1920 alarm(0); 1921 }; 1922 if ($@ ne '') { 1923 chomp($@); 1924 $@ =~ s/ at .+ line .+$//; 1925 $self->debug("unsetting timeout alarm after alarm was triggered ($@)"); 1926 alarm(0); 1927 $Code = COMMAND_FAILED; 1928 if ($@ =~ /^timeout/) { 1929 $Error = $Message = "get_frame() timed out after $self->{timeout} seconds"; 1930 1931 } else { 1932 $Error = $Message = "get_frame() received an error: $@"; 1933 1934 } 1935 return undef; 1936 1937 } else { 1938 return bless($frame, 'Net::EPP::Frame::Response'); 1939 1940 } 1941} 1942 1943# Get details error description including code, message and reason 1944sub _get_error_message { 1945 my ($self, $doc) = @_; 1946 1947 my $code = $self->_get_response_code($doc); 1948 my $error = "Error $code"; 1949 1950 my $message = $self->_get_message($doc); 1951 if ( $message ) { 1952 $error .= ": $message"; 1953 } 1954 1955 my $reason = $self->_get_reason($doc); 1956 if ( $reason ) { 1957 $error .= " ($reason)"; 1958 } 1959 1960 return $error; 1961} 1962 1963sub _get_response_code { 1964 my ($self, $doc) = @_; 1965 my $els = $doc->getElementsByTagNameNS(EPP_XMLNS, 'result'); 1966 if (defined($els)) { 1967 my $el = $els->shift; 1968 if (defined($el)) { 1969 return $el->getAttribute('code'); 1970 } 1971 } 1972 return 2400; 1973} 1974 1975sub _get_message { 1976 my ($self, $doc) = @_; 1977 my $msgs = $doc->getElementsByTagNameNS(EPP_XMLNS, 'msg'); 1978 if (defined($msgs)) { 1979 my $msg = $msgs->shift; 1980 if (defined($msg)) { 1981 return $msg->textContent; 1982 } 1983 } 1984 return ''; 1985} 1986 1987sub _get_reason { 1988 my ($self, $doc) = @_; 1989 my $reasons = $doc->getElementsByTagNameNS(EPP_XMLNS, 'reason'); 1990 if (defined($reasons)) { 1991 my $reason = $reasons->shift; 1992 if (defined($reason)) { 1993 return $reason->textContent; 1994 } 1995 } 1996 return ''; 1997} 1998 1999sub logout { 2000 my $self = shift; 2001 if (defined($self->{authenticated}) && 1 == $self->{authenticated}) { 2002 $self->debug('logging out'); 2003 my $response = $self->request(Net::EPP::Frame::Command::Logout->new); 2004 return undef if (!$response); 2005 } 2006 $self->debug('disconnecting from server'); 2007 $self->disconnect; 2008 $self->{connected} = 0; 2009 return 1; 2010} 2011 2012sub DESTROY { 2013 my $self = shift; 2014 $self->debug('DESTROY() method called'); 2015 $self->logout if (defined($self->{connected}) && 1 == $self->{connected}); 2016} 2017 2018sub debug { 2019 my ($self, $msg) = @_; 2020 my $log = sprintf("%s (%d): %s", scalar(localtime()), $$, $msg); 2021 push(@Log, $log); 2022 print STDERR $log."\n" if (defined($self->{debug}) && $self->{debug} == 1); 2023} 2024 2025=pod 2026 2027=head1 Package Variables 2028 2029=head2 $Net::EPP::Simple::Error 2030 2031This variable contains an english text message explaining the last error 2032to occur. This is may be due to invalid parameters being passed to a 2033method, a network error, or an error response being returned by the 2034server. 2035 2036=head2 $Net::EPP::Simple::Message 2037 2038This variable contains the contains the text content of the 2039C<E<lt>msgE<gt>> element in the response frame for the last transaction. 2040 2041=head2 $Net::EPP::Simple::Code 2042 2043This variable contains the integer result code returned by the server 2044for the last transaction. A successful transaction will always return an 2045error code of 1999 or lower, for an unsuccessful transaction it will be 20462011 or more. If there is an internal client error (due to invalid 2047parameters being passed to a method, or a network error) then this will 2048be set to 2400 (C<COMMAND_FAILED>). See L<Net::EPP::ResponseCodes> for 2049more information about thes codes. 2050 2051=head1 Author 2052 2053CentralNic Ltd (L<http://www.centralnic.com/>). 2054 2055=head1 Copyright 2056 2057This module is (c) 2016 CentralNic Ltd. This module is free software; you can 2058redistribute it and/or modify it under the same terms as Perl itself. 2059 2060=head1 SEE ALSO 2061 2062=over 2063 2064=item * L<Net::EPP::Client> 2065 2066=item * L<Net::EPP::Frame> 2067 2068=item * L<Net::EPP::Proxy> 2069 2070=item * RFCs 5730 and RFC 4934, available from L<http://www.ietf.org/>. 2071 2072=item * The CentralNic EPP site at L<http://www.centralnic.com/registrars/epp>. 2073 2074=back 2075 2076=cut 2077 20781; 2079