lib/Net/OpenSRS.pm

   1 =head1 NAME
   2
   3 Net::OpenSRS - Domain registration via the Tucows OpenSRS HTTPS XML API
   4
   5 =head1 Description
   6
   7 This is a wrapper interface to the DNS portions of the Tucows OpenSRS
   8 HTTPS XML API.
   9
  10 The client library distributed by OpenSRS can be difficult to integrate
  11 into a custom environment, and their web interface becomes quickly
  12 tedious with heavy usage. This is a clean and relatively quick library
  13 to perform the most common API methods described in the OpenSRS API
  14 documentation.
  15
  16 =head1 Examples
  17
  18  use Net::OpenSRS;
  19
  20  my $key = 'Your_API_Key_From_The_Reseller_Interface';
  21  my $srs = Net::OpenSRS->new();
  22
  23  $srs->environment('live');
  24  $srs->set_key( $key );
  25
  26  $srs->set_manage_auth( 'manage_username', 'manage_password' );
  27
  28  my $cookie = $srs->get_cookie( 'spime.net' );
  29  if ($cookie) {
  30      print "Cookie:  $cookie\n";
  31  } else {
  32      print $srs->last_response() . "\n";
  33  }
  34
  35  # do a batch of domain locks
  36  $srs->bulk_lock([ 'example.com', 'example.net', ... ]);
  37
  38  # renew a domain
  39  my $result = $srs->renew_domain( 'example.com' );
  40  ...
  41
  42 =head1 Notes
  43
  44 =head2 Prerequisites
  45
  46 This module requires some setup in the OpenSRS reseller environment
  47 before it will work correctly.
  48
  49 =over 4
  50
  51 =item Reseller account
  52
  53 You need to have an OpenSRS account, of course.  If you aren't an
  54 OpenSRS reseller, this module will be of limited use to you. :)
  55
  56 =item Script API network access
  57
  58 The machine(s) using this module need to have their public IP addresses
  59 added to your 'Script API allow' list in the OpenSRS web interface.
  60 (You'll only need to do this once, assuming your IP doesn't change.)
  61
  62 =item API key generation
  63
  64 You'll need to pregenerate your API keys - also in the the OpenSRS web
  65 interface.  These keys are used for all reseller API authentication.
  66
  67 =back
  68
  69 =head2 Assumptions
  70
  71 OpenSRS allows for a variety of ways to organize your domains.  Because
  72 of this, writing a 'one size fits all' module is rather difficult.
  73 Instead, we make a few assumptions regarding the way people use their
  74 OpenSRS reseller accounts.
  75
  76 **** These assumptions will ultimately determine if this module is right for
  77 you!  Please read them carefully! ****
  78
  79 =over 4
  80
  81 =item Management 'master' account.
  82
  83 We assume that all domains are under one global management owner
  84 account.  If customers want access to the management interface, we're
  85 operating under the idea that you create subaccounts for them -
  86 retainting the master account information for your own use.  (If you
  87 aren't doing this, it really makes things easier for you in the long
  88 run.)
  89
  90 For example, 'spime.net' is my master management account.  Before doing
  91 any register_domain() calls, I call master_domain('spime.net') - then
  92 any transfers or registrations from that point forward are linked to
  93 'spime.net'.  If a customer wants access to the SRS web management
  94 interface, I can then just create a subaccount for just their domain,
  95 so I retain absolute control -- in the event a customer forgets their
  96 password, I'm covered.
  97
  98 =item Usernames
  99
 100 We assume that your management username 'master' account is identical to
 101 your reseller username, and just the passwords differ.
 102
 103 =item Default registration info
 104
 105 We assume you've properly set up default technical contact information,
 106 including your default nameservers, in the OpenSRS reseller web
 107 interface.
 108
 109 =item Return codes
 110
 111 Unless otherwise noted, all methods return true on success, false on
 112 failure, and undefined on caller error.
 113
 114 =back
 115
 116 =head2 Default environment
 117
 118 This library defaults to the TEST environment. (horizon.)  Many API
 119 methods don't work in the test environment (SET COOKIE being the most
 120 notable example, as any API method relying on a cookie doesn't work
 121 either.)  Neither does batch processing.  Most everything else should be
 122 ok.  ( See environment() )
 123
 124 =head2 The '$c' variable
 125
 126 Many methods require customer information.  I leave the method of
 127 fetching this information entirely to you.  All examples below that show
 128 a $c variable expect a hashref (or object) that contain these keys:
 129
 130     my $c = {
 131         firstname => 'John',
 132         lastname  => 'Doe',
 133         city      => 'Portland',
 134         state     => 'Oregon',
 135         country   => 'US',
 136         address   => '555 Someplace Street',
 137         email     => 'john@example.com',
 138         phone     => '503-555-1212',
 139         company   => 'n/a'
 140     };
 141
 142 =cut
 143
 144 package Net::OpenSRS;
 145
 146 use strict;
 147 use warnings;
 148 use LWP::UserAgent;
 149 use XML::Simple;
 150 use Digest::MD5;
 151 use Date::Calc qw/ Add_Delta_Days Today This_Year /;
 152
 153 our $VERSION = '0.06';
 154 my $rv;
 155 *hash = \&Digest::MD5::md5_hex;
 156
 157 #----------------------------------------------------------------------
 158 # utility methods
 159 #----------------------------------------------------------------------
 160
 161 =head1 Utility methods
 162
 163 =over 4
 164
 165 =item new()
 166
 167  my $srs = Net::OpenSRS->new();
 168
 169 Create a new Net::OpenSRS object.  There are no options for this
 170 method.
 171
 172 =cut
 173
 174 sub new
 175 {
 176     my ($class, %opts) = @_;
 177     my $self = {};
 178     bless $self, $class;
 179
 180     $self->{config} = {
 181         use_test_env  => 1,
 182         debug         => 0,
 183         master_domain => undef,
 184
 185         bulkhost => 'https://batch.opensrs.net:55443',
 186
 187         # reseller auth keys, as generated via the reseller website.
 188         live => {
 189             key  => undef,
 190             host => 'https://rr-n1-tor.opensrs.net:55443',
 191         },
 192         test => {
 193             key  => undef,
 194             host => 'https://horizon.opensrs.net:55443',
 195         }
 196     };
 197
 198     return $self;
 199 }
 200
 201 sub debug
 202 {
 203     my $self = shift;
 204     return unless $self->debug_level;
 205     print STDERR shift() . "\n";
 206 }
 207
 208 =item debug_level()
 209
 210 Setting the debug level will print various pieces of information to
 211 STDERR when connecting to OpenSRS.  Use this if something isn't working
 212 the way you think it should be.
 213
 214 =item 0
 215
 216 Disable debugging.
 217
 218 =item 1
 219
 220 Print current environment, host, and HTTP response.
 221
 222 =item 2
 223
 224 Add XML request and response to output.
 225
 226 =item 3
 227
 228 Add SSL debugging to output.
 229
 230 Debugging is off by default.  When called without an argument, returns
 231 the current debug level.
 232
 233 =cut
 234
 235 sub debug_level
 236 {
 237     my ($self, $level) = @_;
 238     return $self->{config}->{debug} unless $level;
 239     $self->{config}->{debug} = $level;
 240     return;
 241 }
 242
 243 =item last_response()
 244
 245 All Net::OpenSRS methods set the last OpenSRS API reply in a temporary
 246 variable.  You can view the contents of this variable using the
 247 last_response() method.
 248
 249 Note that it is reset on each method call.
 250
 251 Returns the last OpenSRS return code and result string, or if passed any
 252 true value, instead returns the full XML (parsed into a hashref) of the
 253 last OpenSRS return. (perfect for Data::Dumper)
 254
 255 Examples:
 256    200: Command Successful
 257    400: Domain example.com does not exist with OpenSRS
 258
 259 =cut
 260
 261 sub last_response
 262 {
 263     my ($self, $obj) = @_;
 264     return $obj ? $rv : $self->{last_response} || '';
 265 }
 266
 267 =item set_manage_auth()
 268
 269  $srs->set_manage_auth( $username, $password );
 270
 271 Set the owner management username and password.  This is used to fetch
 272 cookies, and perform any API methods that require the management cookie.
 273 For specifics on this, see the OpenSRS API documentation.
 274
 275 =cut
 276
 277 sub set_manage_auth
 278 {
 279     my ($self, $user, $pass) = @_;
 280     return undef unless $user && $pass;
 281     $self->{config}->{username} = $user;
 282     $self->{config}->{password} = $pass;
 283     return 1;
 284 }
 285
 286 =item set_key()
 287
 288 Tell the OpenSRS object what secret key to use for authentication.
 289 You can generate a new secret key by using the OpenSRS reseller web
 290 interface.  This key is required to perform any API functions.
 291
 292 set_key() is affected by the current environment().  Calling the
 293 set_key() method while in the test environment only sets the key for the
 294 test environment - likewise for the live environment.  To set a key for
 295 the live environment, you need to call environment('live') B<first>.
 296
 297 =cut
 298
 299 sub set_key
 300 {
 301     my ($self, $key) = @_;
 302     return undef unless $key;
 303     $self->{config}->{ $self->environment }->{key} = $key;
 304     return 1;
 305 }
 306
 307 =item environment()
 308
 309  my $env = $srs->environment;
 310  $srs->environment('live');
 311
 312 Without an argument, returns a string - either 'test', or 'live',
 313 depending on the environment the object is currently using.
 314
 315 The test environment is the default.
 316
 317 If passed an argument (either 'test' or 'live') - switches into the
 318 desired environment.  You will need to set_key() if you were previously
 319 using a different environment, or if you hadn't set_key() yet.
 320
 321 =cut
 322
 323 sub environment
 324 {
 325     my ($self, $env) = @_;
 326     return ($self->{config}->{use_test_env} ? 'test' : 'live')
 327         unless $env && $env =~ /(test|live)/i;
 328     $self->{config}->{use_test_env} =
 329         $1 eq 'test' ? 1 : 0;
 330     return;
 331 }
 332
 333 =item master_domain()
 334
 335  my $master = $srs->master_domain;
 336  $srs->master_domain('spime.net');
 337
 338 Without an argument, returns the currently set 'master domain' account.
 339 Otherwise, it sets the master domain.
 340
 341 New transfers and registrations are linked under this domain, for
 342 centralized management.  See the 'Assumptions' section, above.
 343
 344 =cut
 345
 346 sub master_domain
 347 {
 348     my ($self, $domain) = @_;
 349     return $self->{config}->{master_domain} unless $domain;
 350     $self->{config}->{master_domain} = $domain;
 351     return;
 352 }
 353
 354 # set last status messages/codes in $self,
 355 # for the benefit of the caller.
 356 sub _set_response
 357 {
 358     my $self = shift;
 359     $rv->{response_text} =~ s/Error: //;
 360     $self->{last_response} = $rv->{response_code} . ": " . $rv->{response_text};
 361     return;
 362 }
 363
 364 #----------------------------------------------------------------------
 365 # SRS API methods
 366 #----------------------------------------------------------------------
 367
 368 =back
 369
 370 =head1 OpenSRS API methods
 371
 372 =over 4
 373
 374 =item bulk_lock() / bulk_unlock()
 375
 376 Locks or unlocks up to 1000 domains at a time.
 377
 378  my $result = $srs->bulk_lock([ 'example.com', 'example.net' ]);
 379
 380 Returns remote bulk queue id on successful batch submission.
 381
 382 =cut
 383
 384 sub bulk_lock
 385 {
 386     my $self = shift;
 387     return $self->_bulk_action( 'lock', @_ );
 388 }
 389
 390 sub bulk_unlock
 391 {
 392     my $self = shift;
 393     return $self->_bulk_action( 'unlock', @_ );
 394 }
 395
 396 sub _bulk_action
 397 {
 398     my ( $self, $toggle, $domains ) = @_;
 399     return undef unless $toggle =~ /lock|unlock/i &&
 400                         ref $domains;
 401     return undef if scalar @$domains >= 1000;
 402
 403     $rv = $self->make_request(
 404         {
 405             batch   => 1,
 406             action  => 'submit',
 407             object  => 'bulk_change',
 408             attributes => {
 409                 change_type => 'domain_lock',
 410                 change_items => $domains,
 411                 op_type => lc $toggle,
 412             }
 413         }
 414     );
 415     return undef unless $rv;
 416
 417     $self->_set_response;
 418     return $rv->{is_success} ? $rv->{bulk_change_req_id} : 0;
 419 }
 420
 421 =item check_queued_request()
 422
 423  my $result = $srs->check_queued_request( $queue_id );
 424
 425 Requires queue id - returned from batch methods such as bulk_lock().
 426 Always returns hashref of queue command on success.
 427 Check $srs->last_response() for status progress.
 428
 429 =cut
 430
 431 sub check_queued_request
 432 {
 433     my ( $self, $id ) = @_;
 434     return undef unless $id;
 435
 436     $rv = $self->make_request(
 437         {
 438             action  => 'query_queued_request',
 439             object  => 'domain',
 440             attributes => {
 441                 request_id => $id,
 442             }
 443         }
 444     );
 445     return undef unless $rv;
 446
 447     $self->_set_response;
 448     return $rv->{attributes}->{request_data};
 449 }
 450
 451 =item check_transfer()
 452
 453  my $result = $srs->check_transfer( 'example.com' );
 454
 455 Checks the status of a transfer in progress.  Returns hashref of
 456 'contact_email', 'status', and 'last_update_time' for a given domain
 457 transfer.  The 'status' key is always one of the following:
 458
 459         pending_owner  (waiting on owner confirmation)
 460         pending_admin  (waiting on opensrs staff confirmation)
 461         pending_registry  (waiting on register to complete)
 462         completed  (transfer done)
 463         cancelled  (reseller cancelled transfer in progress)
 464         undefined  (no transfer in progress)
 465
 466 If the domain in question has no transfer in progress - instead checks
 467 to see if the domain is capable of transfer.  Returns hashref of
 468 'transferrable' (boolean) and 'reason' (string).
 469
 470 =cut
 471
 472 sub check_transfer
 473 {
 474     my ( $self, $domain ) = @_;
 475     return undef unless $domain;
 476
 477     $rv = $self->make_request(
 478         {
 479             action     => 'check_transfer',
 480             object     => 'domain',
 481             attributes => {
 482                 domain              => $domain,
 483                 get_request_address => 1,
 484             }
 485         }
 486     );
 487     return undef unless $rv;
 488
 489     $self->_set_response;
 490     if ( $rv->{attributes}->{status} ) {
 491         return {
 492             status           => $rv->{attributes}->{status},
 493             last_update_time => $rv->{attributes}->{unixtime},
 494             contact_email    => $rv->{attributes}->{request_address}
 495         };
 496     }
 497     else {
 498         return $rv->{attributes}; #(transferrable bool and reason)
 499     }
 500 }
 501
 502 =item get_cookie()
 503
 504 OpenSRS management APIs require a cookie to be generated, and sent along
 505 with the API request.
 506
 507  $cookie = $srs->get_cookie( 'example.com ');
 508  ($cookie, $expiration_date) = $srs->get_cookie( 'example.com ');
 509
 510 Make sure you've set_manage_auth() before attempting any cookie required
 511 APIs.
 512
 513 Returns cookie on success, undefined on error.  (Check error with
 514 last_response())
 515
 516 In array context, returns cookie and expiration date of the domain.
 517
 518 =cut
 519
 520 sub get_cookie
 521 {
 522     my ($self, $domain) = @_;
 523     return undef unless $domain;
 524     $rv = $self->make_request(
 525         {
 526             action     => 'set',
 527             object     => 'cookie',
 528             attributes => {
 529                 reg_username => $self->{config}->{username},
 530                 reg_password => $self->{config}->{password},
 531                 domain => $domain
 532             }
 533         }
 534     );
 535     return undef unless $rv;
 536
 537     $self->_set_response;
 538     if ($rv->{is_success}) {
 539         return
 540           wantarray
 541           ? ( $rv->{attributes}->{cookie}, $rv->{attributes}->{expiredate} )
 542           : $rv->{attributes}->{cookie};
 543     }
 544     return undef;
 545 }
 546
 547 =item get_expiring_domains()
 548
 549  my $results = $srs->get_expiring_domains( 60 );
 550
 551  Fetch and return OpenSRS hashref of expiring domains, within
 552  the specified timeperiod.  (In days.)
 553
 554  Time period defaults to 30 days.
 555
 556 =cut
 557
 558 sub get_expiring_domains
 559 {
 560     my ($self, $timeframe) = @_;
 561     $timeframe ||= 30;
 562
 563     my $today   = join '-', map { sprintf( "%02d", $_ ) } Date::Calc::Today();
 564     my $expdate = join '-', map { sprintf( "%02d", $_ ) }
 565       Date::Calc::Add_Delta_Days( ( split '-', $today ), $timeframe );
 566
 567     $rv = $self->make_request(
 568         {
 569             action     => 'get_domains_by_expiredate',
 570             object     => 'domain',
 571             attributes => {
 572                 limit    => 1000,
 573                 exp_from => $today,
 574                 exp_to   => $expdate,
 575             }
 576         }
 577     );
 578     return undef unless $rv;
 579
 580     $self->_set_response;
 581     return $rv->{attributes}->{exp_domains} if $rv->{is_success};
 582     return undef;
 583 }
 584
 585 =item is_available()
 586
 587 Hey OpenSRS! Is this domain registered, or is it available?
 588
 589  my $result = $srs->is_available( 'example.com ');
 590
 591 Returns true if the domain is available, false if it is already
 592 registered.
 593
 594 =cut
 595
 596 sub is_available
 597 {
 598     my ($self, $domain) = @_;
 599     return undef unless $domain;
 600     $rv = $self->make_request(
 601         {
 602             action     => 'lookup',
 603             object     => 'domain',
 604             attributes => {
 605                 domain => $domain
 606             }
 607         }
 608     );
 609     return undef unless $rv;
 610     $self->_set_response;
 611     return undef unless $rv->{is_success};
 612     return $rv->{response_code} == 210 ? 1 : 0;
 613 }
 614
 615 =item register_domain()
 616
 617  my $result = $srs->register_domain( 'example.com', $c );
 618
 619 Register a new domain.  Default nameserver and tech info used from
 620 OpenSRS settings.
 621
 622 =cut
 623
 624 sub register_domain
 625 {
 626     my ($self, $domain, $c, $transfer) = @_;
 627     return undef unless $domain;
 628
 629     # sanity checks
 630     unless ($self->{config}->{username}) {
 631         $self->debug("Management auth not set.");
 632         return undef;
 633     }
 634     unless (ref $c) {
 635         $self->debug("2nd arg must be a reference to customer info.");
 636         return undef;
 637     }
 638
 639     my $epp_phone = $c->{phone};
 640     $epp_phone =~ s/[\.\-]//g;
 641     $epp_phone = '+1.' . $epp_phone;
 642
 643     # blah, this sucks.
 644     # it would be really nice if OpenSRS figured out the country -> code
 645     # conversion on their end of things.
 646     my %country_codes = (
 647         'Afghanistan'                            => 'AF',
 648         'Albania'                                => 'AL',
 649         'Algeria'                                => 'DZ',
 650         'American Samoa'                         => 'AS',
 651         'Andorra'                                => 'AD',
 652         'Angola'                                 => 'AO',
 653         'Anguilla'                               => 'AI',
 654         'Antarctica'                             => 'AQ',
 655         'Antigua And Barbuda'                    => 'AG',
 656         'Argentina'                              => 'AR',
 657         'Armenia'                                => 'AM',
 658         'Aruba'                                  => 'AW',
 659         'Australia'                              => 'AU',
 660         'Austria'                                => 'AT',
 661         'Azerbaijan'                             => 'AZ',
 662         'Bahamas'                                => 'BS',
 663         'Bahrain'                                => 'BH',
 664         'Bangladesh'                             => 'BD',
 665         'Barbados'                               => 'BB',
 666         'Belarus'                                => 'BY',
 667         'Belgium'                                => 'BE',
 668         'Belize'                                 => 'BZ',
 669         'Benin'                                  => 'BJ',
 670         'Bermuda'                                => 'BM',
 671         'Bhutan'                                 => 'BT',
 672         'Bolivia'                                => 'BO',
 673         'Bosnia Hercegovina'                     => 'BA',
 674         'Botswana'                               => 'BW',
 675         'Bouvet Island'                          => 'BV',
 676         'Brazil'                                 => 'BR',
 677         'British Indian Ocean Territory'         => 'IO',
 678         'Brunei Darussalam'                      => 'BN',
 679         'Bulgaria'                               => 'BG',
 680         'Burkina Faso'                           => 'BF',
 681         'Burundi'                                => 'BI',
 682         'Cambodia'                               => 'KH',
 683         'Cameroon'                               => 'CM',
 684         'Canada'                                 => 'CA',
 685         'Cape Verde'                             => 'CV',
 686         'Cayman Islands'                         => 'KY',
 687         'Central African Republic'               => 'CF',
 688         'Chad'                                   => 'TD',
 689         'Chile'                                  => 'CL',
 690         'China'                                  => 'CN',
 691         'Christmas Island'                       => 'CX',
 692         'Cocos (Keeling) Islands'                => 'CC',
 693         'Colombia'                               => 'CO',
 694         'Comoros'                                => 'KM',
 695         'Congo'                                  => 'CG',
 696         'Congo The Democratic Republic Of'       => 'CD',
 697         'Cook Islands'                           => 'CK',
 698         'Costa Rica'                             => 'CR',
 699         'Cote D\'Ivoire'                         => 'CI',
 700         'Croatia'                                => 'HR',
 701         'Cuba'                                   => 'CU',
 702         'Cyprus'                                 => 'CY',
 703         'Czech Republic'                         => 'CZ',
 704         'Denmark'                                => 'DK',
 705         'Djibouti'                               => 'DJ',
 706         'Dominica'                               => 'DM',
 707         'Dominican Republic'                     => 'DO',
 708         'Ecuador'                                => 'EC',
 709         'Egypt'                                  => 'EG',
 710         'El Salvador'                            => 'SV',
 711         'Equatorial Guinea'                      => 'GQ',
 712         'Eritrea'                                => 'ER',
 713         'Estonia'                                => 'EE',
 714         'Ethiopia'                               => 'ET',
 715         'Falkland Islands (Malvinas)'            => 'FK',
 716         'Faroe Islands'                          => 'FO',
 717         'Fiji'                                   => 'FJ',
 718         'Finland'                                => 'FI',
 719         'France'                                 => 'FR',
 720         'French Guiana'                          => 'GF',
 721         'French Polynesia'                       => 'PF',
 722         'French Southern Territories'            => 'TF',
 723         'Gabon'                                  => 'GA',
 724         'Gambia'                                 => 'GM',
 725         'Georgia'                                => 'GE',
 726         'Germany'                                => 'DE',
 727         'Ghana'                                  => 'GH',
 728         'Gibraltar'                              => 'GI',
 729         'Greece'                                 => 'GR',
 730         'Greenland'                              => 'GL',
 731         'Grenada'                                => 'GD',
 732         'Guadeloupe'                             => 'GP',
 733         'Guam'                                   => 'GU',
 734         'Guatemela'                              => 'GT',
 735         'Guinea'                                 => 'GN',
 736         'Guinea-Bissau'                          => 'GW',
 737         'Guyana'                                 => 'GY',
 738         'Haiti'                                  => 'HT',
 739         'Heard and McDonald Islands'             => 'HM',
 740         'Honduras'                               => 'HN',
 741         'Hong Kong'                              => 'HK',
 742         'Hungary'                                => 'HU',
 743         'Iceland'                                => 'IS',
 744         'India'                                  => 'IN',
 745         'Indonesia'                              => 'ID',
 746         'Iran (Islamic Republic Of)'             => 'IR',
 747         'Iraq'                                   => 'IQ',
 748         'Ireland'                                => 'IE',
 749         'Israel'                                 => 'IL',
 750         'Italy'                                  => 'IT',
 751         'Jamaica'                                => 'JM',
 752         'Japan'                                  => 'JP',
 753         'Jordan'                                 => 'JO',
 754         'Kazakhstan'                             => 'KZ',
 755         'Kenya'                                  => 'KE',
 756         'Kiribati'                               => 'KI',
 757         'Korea, Democratic People\'s Republic Of' => 'KP',
 758         'Korea, Republic Of'                     => 'KR',
 759         'Kuwait'                                 => 'KW',
 760         'Kyrgyzstan'                             => 'KG',
 761         'Lao People\'s Democratic Republic'      => 'LA',
 762         'Latvia'                                 => 'LV',
 763         'Lebanon'                                => 'LB',
 764         'Lesotho'                                => 'LS',
 765         'Liberia'                                => 'LR',
 766         'Libyan Arab Jamahiriya'                 => 'LY',
 767         'Liechtenstein'                          => 'LI',
 768         'Lithuania'                              => 'LT',
 769         'Luxembourg'                             => 'LU',
 770         'Macau'                                  => 'MO',
 771         'Macedonia'                              => 'MK',
 772         'Madagascar'                             => 'MG',
 773         'Malawi'                                 => 'MW',
 774         'Malaysia'                               => 'MY',
 775         'Maldives'                               => 'MV',
 776         'Mali'                                   => 'ML',
 777         'Malta'                                  => 'MT',
 778         'Marshall Islands'                       => 'MH',
 779         'Martinique'                             => 'MQ',
 780         'Mauritania'                             => 'MR',
 781         'Mauritius'                              => 'MU',
 782         'Mayotte'                                => 'YT',
 783         'Mexico'                                 => 'MX',
 784         'Micronesia, Federated States Of'        => 'FM',
 785         'Moldova, Republic Of'                   => 'MD',
 786         'Monaco'                                 => 'MC',
 787         'Mongolia'                               => 'MN',
 788         'Montserrat'                             => 'MS',
 789         'Morocco'                                => 'MA',
 790         'Mozambique'                             => 'MZ',
 791         'Myanmar'                                => 'MM',
 792         'Namibia'                                => 'NA',
 793         'Nauru'                                  => 'NR',
 794         'Nepal'                                  => 'NP',
 795         'Netherlands'                            => 'NL',
 796         'Netherlands Antilles'                   => 'AN',
 797         'New Caledonia'                          => 'NC',
 798         'New Zealand'                            => 'NZ',
 799         'Nicaragua'                              => 'NI',
 800         'Niger'                                  => 'NE',
 801         'Nigeria'                                => 'NG',
 802         'Niue'                                   => 'NU',
 803         'Norfolk Island'                         => 'NF',
 804         'Northern Mariana Islands'               => 'MP',
 805         'Norway'                                 => 'NO',
 806         'Oman'                                   => 'OM',
 807         'Pakistan'                               => 'PK',
 808         'Palau'                                  => 'PW',
 809         'Palestine'                              => 'PS',
 810         'Panama'                                 => 'PA',
 811         'Papua New Guinea'                       => 'PG',
 812         'Paraguay'                               => 'PY',
 813         'Peru'                                   => 'PE',
 814         'Philippines'                            => 'PH',
 815         'Pitcairn'                               => 'PN',
 816         'Poland'                                 => 'PL',
 817         'Portugal'                               => 'PT',
 818         'Puerto Rico'                            => 'PR',
 819         'Qatar'                                  => 'QA',
 820         'Reunion'                                => 'RE',
 821         'Romania'                                => 'RO',
 822         'Russian Federation'                     => 'RU',
 823         'Rwanda'                                 => 'RW',
 824         'Saint Helena'                           => 'SH',
 825         'Saint Kitts And Nevis'                  => 'KN',
 826         'Saint Lucia'                            => 'LC',
 827         'Saint Pierre and Miquelon'              => 'PM',
 828         'Saint Vincent and The Grenadines'       => 'VC',
 829         'Samoa'                                  => 'WS',
 830         'San Marino'                             => 'SM',
 831         'Sao Tome and Principe'                  => 'ST',
 832         'Saudi Arabia'                           => 'SA',
 833         'Senegal'                                => 'SN',
 834         'Serbia and Montenegro'                  => 'CS',
 835         'Seychelles'                             => 'SC',
 836         'Sierra Leone'                           => 'SL',
 837         'Singapore'                              => 'SG',
 838         'Slovakia'                               => 'SK',
 839         'Slovenia'                               => 'SI',
 840         'Solomon Islands'                        => 'SB',
 841         'Somalia'                                => 'SO',
 842         'South Africa'                           => 'ZA',
 843         'South Georgia and The Sandwich Islands' => 'GS',
 844         'Spain'                                  => 'ES',
 845         'Sri Lanka'                              => 'LK',
 846         'Sudan'                                  => 'SD',
 847         'Suriname'                               => 'SR',
 848         'Svalbard and Jan Mayen Islands'         => 'SJ',
 849         'Swaziland'                              => 'SZ',
 850         'Sweden'                                 => 'SE',
 851         'Switzerland'                            => 'CH',
 852         'Syrian Arab Republic'                   => 'SY',
 853         'Taiwan'                                 => 'TW',
 854         'Tajikista'                              => 'TJ',
 855         'Tanzania, United Republic Of'           => 'TZ',
 856         'Thailand'                               => 'TH',
 857         'Timor-Leste'                            => 'TL',
 858         'Togo'                                   => 'TG',
 859         'Tokelau'                                => 'TK',
 860         'Tonga'                                  => 'TO',
 861         'Trinidad and Tobago'                    => 'TT',
 862         'Tunisia'                                => 'TN',
 863         'Turkey'                                 => 'TR',
 864         'Turkmenistan'                           => 'TM',
 865         'Turks and Caicos Islands'               => 'TC',
 866         'Tuvalu'                                 => 'TV',
 867         'Uganda'                                 => 'UG',
 868         'Ukraine'                                => 'UA',
 869         'United Arab Emirates'                   => 'AE',
 870         'United Kingdom (GB)'                    => 'GB',
 871         'United Kingdom (UK)'                    => 'UK',
 872         'United States'                          => 'US',
 873         'United States Minor Outlying Islands'   => 'UM',
 874         'Uruguay'                                => 'UY',
 875         'Uzbekistan'                             => 'UZ',
 876         'Vanuatu'                                => 'VU',
 877         'Vatican City State'                     => 'VA',
 878         'Venezuela'                              => 'VE',
 879         'Vietnam'                                => 'VN',
 880         'Virgin Islands (British)'               => 'VG',
 881         'Virgin Islands (U.S.)'                  => 'VI',
 882         'Wallis and Futuna Islands'              => 'WF',
 883         'Western Sahara'                         => 'EH',
 884         'Yemen Republic of'                      => 'YE',
 885         'Zambia'                                 => 'ZM',
 886         'Zimbabwe'                               => 'ZW'
 887     );  # end suckage
 888
 889     # attempt countryname translation if needed
 890     if ( $c->{country} !~ m/^[A-Z]{2,3}$/ ) {
 891         $c->{country} = $country_codes{$c->{country}};
 892
 893         unless ( defined( $c->{country} ) ) {
 894             $self->debug("Invalid country.");
 895             return undef;
 896         }
 897     }
 898
 899     # build contact hashref from customer info.
 900     my $contact_info = {
 901         first_name  => $c->{firstname},
 902         last_name   => $c->{lastname},
 903         city        => $c->{city},
 904         state       => $c->{state},
 905         country     => $c->{country},
 906         address1    => $c->{address},
 907         postal_code => $c->{zip},
 908         email       => $c->{email},
 909         phone       => $epp_phone,
 910         org_name    => $c->{company} || 'n/a',
 911     };
 912
 913
 914     my $hashref = {
 915             action     => 'sw_register',
 916             object     => 'domain',
 917             attributes => {
 918                 domain              => $domain,
 919                 custom_nameservers  => 0,
 920                 custom_tech_contact => 0,
 921                 auto_renew          => 0,
 922                 period              => 1,
 923                 f_lock_domain       => 1,
 924                 contact_set         => {
 925                     admin   => $contact_info,
 926                     billing => $contact_info,
 927                     owner   => $contact_info
 928                 },
 929                 reg_username => $self->{config}->{username},
 930                 reg_password => $self->{config}->{password},
 931                 reg_type   => $transfer ? 'transfer' : 'new',
 932                 reg_domain => $self->{config}->{master_domain}, # link domain to the 'master' account
 933             }
 934         };
 935
 936     if ( $domain =~ /\.au$/ ) {
 937         $hashref->{'attributes'}->{'custom_tech_contact'} = 1;
 938         $hashref->{'attributes'}->{'contact_set'}->{'tech'} = $contact_info;
 939         my $au_registrant_info = { 'registrant_name' => $c->{'registrant_name'},
 940                                 'eligibility_type' => $c->{'eligibility_type'},
 941                               };
 942         $hashref->{'attributes'}->{'tld_data'}->{'au_registrant_info'} = $au_registrant_info;
 943     }
 944
 945     $rv = $self->make_request($hashref);
 946     $self->_set_response;
 947     return $rv->{is_success};
 948 }
 949
 950 =item renew_domain()
 951
 952  my $result = $srs->renew_domain( 'example.com', 1 );
 953
 954 Renew a domain for a period of time in years. 1 year is the default.
 955
 956 =cut
 957
 958 sub renew_domain
 959 {
 960     my ($self, $domain, $years) = @_;
 961     return undef unless $domain;
 962     $years ||= 1;
 963
 964     # sanity checks
 965     unless ($self->{config}->{username}) {
 966         $self->debug("Management auth not set.");
 967         return undef;
 968     }
 969
 970     # get current expiration year (why do they need this, again?)
 971     my (undef, $expiration) = $self->get_cookie( $domain );
 972     $expiration = $1 if $expiration =~ /^(\d{4})-/;
 973     $expiration ||= Date::Calc::This_Year();
 974
 975     $rv = $self->make_request(
 976         {
 977             action     => 'renew',
 978             object     => 'domain',
 979             attributes => {
 980                 domain                => $domain,
 981                 auto_renew            => 0,
 982                 handle                => 'process',
 983                 period                => $years,
 984                 currentexpirationyear => $expiration,
 985             }
 986         }
 987     );
 988     $self->_set_response;
 989     return $rv->{is_success};
 990 }
 991
 992 =item revoke_domain()
 993
 994 Revoke a previously registered domain.  This only works if the domain is
 995 still within the grace period as defined by the registrar.
 996 Requires you to have called set_manage_auth() B<first>.
 997
 998  my $result = $srs->revoke_domain( 'example.com' );
 999
1000 Returns true if the revoke is successful, false otherwise.
1001 Returns undefined on error.
1002
1003 =cut
1004
1005 sub revoke_domain
1006 {
1007     my ($self, $domain) = @_;
1008     return undef unless $domain;
1009     unless ($self->{config}->{username}) {
1010         $self->debug("Management auth not set.");
1011         return undef;
1012     }
1013     $rv = $self->make_request(
1014         {
1015             action     => 'revoke',
1016             object     => 'domain',
1017             attributes => {
1018                 reseller => $self->{config}->{username},
1019                 domain => $domain,
1020             }
1021         }
1022     );
1023     $self->_set_response;
1024     return $rv->{is_success};
1025 }
1026
1027 =item transfer_domain()
1028
1029  my $result = $srs->transfer_domain( 'example.com', $c );
1030
1031 Transfer a domain under your control.
1032 Returns true on success, false on failure, and undefined on caller error.
1033
1034 =cut
1035
1036 sub transfer_domain
1037 {
1038     my $self = shift;
1039     return $self->register_domain( @_, 1 );
1040 }
1041
1042 =item make_request()
1043
1044 This method is the real workhorse of this module.  If any OpenSRS API
1045 isn't explicity implemented in this module as a method call (such as
1046 get_cookie(), bulk_lock(), etc), you can use make_request() to build and send
1047 the API yourself.
1048
1049 Examples:
1050
1051  my $result = $srs->make_request(
1052      {
1053          batch   => 1,
1054          action  => 'submit',
1055          object  => 'bulk_change',
1056          attributes => {
1057              change_type => 'domain_lock',
1058              change_items => [ 'example.com', 'example.net' ],
1059              op_type => 'lock',
1060          }
1061      }
1062  );
1063
1064  my $result = $srs->make_request(
1065      {
1066          action     => 'lookup',
1067          object     => 'domain',
1068          attributes => {
1069              domain => 'example.com'
1070          }
1071      }
1072  );
1073
1074 Returns a hashref containing parsed XML results from OpenSRS.
1075
1076 Example return:
1077
1078  {
1079      'protocol' => 'XCP',
1080      'object' => 'DOMAIN',
1081      'response_text' => 'Domain taken',
1082      'action' => 'REPLY',
1083      'response_code' => '211',
1084      'attributes' => {
1085          'status' => 'taken',
1086          'match' => {}
1087      },
1088      'is_success' => '1'
1089  }
1090
1091 =cut
1092
1093 # build opensrs xml protocol string.  submit.
1094 # convert xml response to data structure, and return.
1095 sub make_request
1096 {
1097     my ($self, $data) = @_;
1098     return undef unless ref $data;
1099
1100     $self->debug("Using " . $self->environment . " environment.");
1101
1102     my $key  = $self->{config}->{ $self->environment }->{key};
1103     my $host = $self->{config}->{ $self->environment }->{host};
1104     $ENV{HTTPS_DEBUG} = 1 if $self->debug_level > 2;
1105
1106     unless ($key) {
1107         $self->debug("Authentication key not set.");
1108         return undef;
1109     }
1110
1111     my $action = uc $data->{action};
1112     my $object = uc $data->{object};
1113
1114     # build our XML request.
1115     # lets not bother with anything super fancy,
1116     # everything but the item keys are always static anyway.
1117     my $xml;
1118     $xml = <<XML;
1119 <?xml version='1.0' encoding="UTF-8" standalone="no" ?>
1120 <!DOCTYPE OPS_envelope SYSTEM "ops.dtd">
1121 <OPS_envelope>
1122 <header><version>0.9</version></header>
1123 <body>
1124 <data_block>
1125 <dt_assoc>
1126   <item key="protocol">XCP</item>
1127   <item key="action">$action</item>
1128   <item key="object">$object</item>
1129 XML
1130
1131     $xml .= "  <item key=\"cookie\">$data->{cookie}</item>\n" if $data->{cookie};
1132
1133 $xml .= <<XML;
1134   <item key="attributes">
1135     <dt_assoc>
1136 XML
1137
1138     foreach (sort keys %{ $data->{attributes} }) {
1139         my $val = $data->{attributes}->{$_};
1140         $xml .= $self->_format( $val, 4 );
1141     }
1142     $xml .= <<XML;
1143     </dt_assoc>
1144   </item>
1145 </dt_assoc>
1146 </data_block>
1147 </body>
1148 </OPS_envelope>
1149 XML
1150
1151     # whoof, ok.  got our request built.  lets ship it off.
1152     if ($self->debug_level > 1) {
1153         $self->debug("\nClient Request XML:\n" . '-' x 30);
1154         $self->debug($xml);
1155     }
1156
1157     $host = $self->{config}->{bulkhost} if $data->{batch};
1158     $self->debug("Making request to $host...");
1159     my $ua = LWP::UserAgent->new( timeout => 20, agent => "Net::OpenSRS/$VERSION" );
1160     unless ($ua) {
1161         $self->debug("Unable to contact remote host.");
1162         return undef;
1163     }
1164
1165     my $res = $ua->post(
1166         $host,
1167         'Content-Type' => 'text/xml',
1168         'X-Username'   => $self->{config}->{username},
1169         'X-Signature'  => hash( hash( $xml, $key ), $key ),
1170         'Content'      => $xml
1171     );
1172
1173     my $struct;
1174     if ( $res->is_success ) {
1175         $self->debug("HTTP result: " . $res->status_line);
1176         my $rslt = $res->content;
1177         # OpenSRS renew response triggers Expat parser error due to spaces in element name
1178         $rslt =~ s/registration expiration date/registration_expiration_date/g;
1179
1180         eval { $struct = XML::Simple::XMLin(
1181                  $rslt,
1182                  'KeyAttr' => [ 'dt_assoc' ],
1183                  'GroupTags' => { 'dt_assoc' => 'item',  'dt_array' => 'item' },
1184                );
1185         };
1186
1187         if ($self->debug_level > 1) {
1188             $self->debug("\nOpenSRS Response XML:\n" . '-' x 30);
1189             $self->debug($res->content);
1190             $self->debug('');
1191         }
1192
1193         # get the struct looking just how we want it.
1194         # (de-nastify it.)
1195         (undef, $struct) = _denastify( $struct->{body}->{data_block} );
1196     }
1197     else {
1198         $self->debug("HTTP error: " . $res->status_line);
1199         return undef;
1200     }
1201
1202     $rv = $struct;
1203     $self->_set_response;
1204     return $self->last_response(1);
1205 }
1206
1207 # encode special characters
1208
1209 my %encode_hash = (
1210   '<' => '&lt;',
1211   '>' => '&gt;',
1212   "'" => '&apos;',
1213   '"' => '&quot;',
1214   '&' => '&amp;',
1215 );
1216
1217 sub _encode
1218 {
1219   my $arg = shift;
1220   return $arg unless ($arg =~/\<|\>|\'|\"|\&/);
1221   $arg =~ s/(\<|\>|\'|\"|\&)/$encode_hash{$1}/ge;
1222   $arg
1223 }
1224
1225 # format perl structs into opensrs XML
1226 sub _format
1227 {
1228     my ($self, $val, $indent) = @_;
1229     my $xml;
1230
1231     $indent ||= 6;
1232     my $sp = ' ' x $indent;
1233
1234     if ( ref $val eq 'ARRAY' ) {
1235         my $c = 0;
1236         $xml .= "$sp<item key=\"$_\">\n";
1237         $xml .= "$sp  <dt_array>\n";
1238         foreach (map { _encode($_) } sort @$val) {
1239             $xml .= "$sp    <item key=\"$c\">$_</item>\n";
1240             $c++;
1241         }
1242         $xml .= "$sp  </dt_array>\n";
1243         $xml .= "$sp</item>\n";
1244     }
1245
1246     elsif ( ref $val eq 'HASH' ) {
1247         $xml .= "$sp<item key=\"$_\">\n";
1248         $xml .= "$sp<dt_assoc>\n";
1249         foreach (sort keys %$val) {
1250             $xml .= $self->_format( $val->{$_} );
1251         }
1252         $xml .= "$sp</dt_assoc>\n";
1253         $xml .= "$sp</item>\n";
1254     }
1255
1256     else {
1257         $val = _encode($val);
1258         $xml .= "$sp<item key=\"$_\">$val</item>\n";
1259     }
1260
1261     return $xml;
1262 }
1263
1264 sub _denastify {
1265     my ($arg) = ( shift );
1266
1267     if ( 0 ) {
1268       eval { use Data::Dumper };
1269       warn $@ if $@;
1270       warn "_denastify\n". Dumper($arg) unless $@;
1271     }
1272
1273     if ( ref($arg) eq 'HASH' ) {
1274         my $value;
1275         if ( exists( $arg->{content} ) ) {
1276             $value = $arg->{content};
1277         } elsif ( exists( $arg->{dt_array} ) ) {
1278             my $array = $arg->{dt_array};
1279             $array = [ $array ] unless ref($array) eq 'ARRAY';
1280             $value = [ map {
1281                                { map { _denastify($_) } @{ $_->{dt_assoc} } }
1282                            }
1283                        @$array
1284                      ];
1285         } elsif ( exists( $arg->{dt_assoc} ) ) {
1286             my $array = $arg->{dt_assoc};
1287             $array = [ $array ] unless ref($array) eq 'ARRAY';
1288             $value = { map { _denastify($_) } @$array };
1289         }
1290         return ( $arg->{key} => $value );
1291     }
1292     ();
1293 }
1294
1295 =back
1296
1297 =head1 Author
1298
1299 Mahlon E. Smith I<mahlon@martini.nu> for Spime Solutions Group
1300 I<(www.spime.net)>
1301
1302 =cut
1303
1304 1;