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.07_01';
 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     # attempt countryname translation if needed
 640     if ( $c->{country} !~ m/^[A-Z]{2,3}$/ ) {
 641         require Locales;
 642         $c->{country} = uc( Locales->new->get_code_from_territory($c->{country}) );
 643
 644         unless ( defined( $c->{country} ) ) {
 645             $self->debug("Invalid country.");
 646             return undef;
 647         }
 648     }
 649
 650     my $epp_phone = _parse_phone($c->{phone});
 651     unless ( defined( $epp_phone ) ) {
 652         $self->debug("Invalid phone number.");
 653         return undef;
 654     }
 655
 656     # build contact hashref from customer info.
 657     my $contact_info = {
 658         first_name  => $c->{first_name} || $c->{firstname},
 659         last_name   => $c->{last_name} || $c->{lastname},
 660         city        => $c->{city},
 661         state       => $c->{state},
 662         country     => $c->{country},
 663         address1    => $c->{address1} || $c->{address},
 664         $c->{address2} ? ( address2 => $c->{address2} ) : (),
 665         postal_code => $c->{postal_code} || $c->{zip},
 666         email       => $c->{email},
 667         phone       => $epp_phone,
 668         org_name    => $c->{org_name} || $c->{company} || 'n/a',
 669     };
 670
 671     my $hashref = {
 672             action     => 'sw_register',
 673             object     => 'domain',
 674             attributes => {
 675                 domain              => $domain,
 676                 custom_nameservers  => exists $c->{nameserver_list} ? 1 : 0,
 677                 exists $c->{nameserver_list} ? ( nameserver_list => $c->{nameserver_list} ) : (),
 678                 custom_tech_contact => 0,
 679                 auto_renew          => $c->{auto_renew} || 0,
 680                 period              => $c->{period} || 1,
 681                 f_lock_domain       => 1,
 682                 contact_set         => {
 683                     admin   => $contact_info,
 684                     billing => $contact_info,
 685                     owner   => $contact_info
 686                 },
 687                 reg_username => $self->{config}->{username},
 688                 reg_password => $self->{config}->{password},
 689                 reg_type   => $transfer ? 'transfer' : 'new',
 690                 reg_domain => $self->{config}->{master_domain}, # link domain to the 'master' account
 691             }
 692         };
 693
 694     if ( $domain =~ /\.au$/ ) {
 695         $hashref->{'attributes'}->{'custom_tech_contact'} = 1;
 696         $hashref->{'attributes'}->{'contact_set'}->{'tech'} = $contact_info;
 697         my $au_registrant_info = { 'registrant_name' => $c->{'registrant_name'},
 698                                 'eligibility_type' => $c->{'eligibility_type'},
 699                               };
 700         $hashref->{'attributes'}->{'tld_data'}->{'au_registrant_info'} = $au_registrant_info;
 701     }
 702
 703     $rv = $self->make_request($hashref);
 704     $self->_set_response;
 705     return $rv->{is_success};
 706 }
 707
 708 =item renew_domain()
 709
 710  my $result = $srs->renew_domain( 'example.com', 1 );
 711
 712 Renew a domain for a period of time in years. 1 year is the default.
 713
 714 =cut
 715
 716 sub renew_domain
 717 {
 718     my ($self, $domain, $years) = @_;
 719     return undef unless $domain;
 720     $years ||= 1;
 721
 722     # sanity checks
 723     unless ($self->{config}->{username}) {
 724         $self->debug("Management auth not set.");
 725         return undef;
 726     }
 727
 728     # get current expiration year (why do they need this, again?)
 729     my (undef, $expiration) = $self->get_cookie( $domain );
 730     $expiration = $1 if $expiration =~ /^(\d{4})-/;
 731     $expiration ||= Date::Calc::This_Year();
 732
 733     $rv = $self->make_request(
 734         {
 735             action     => 'renew',
 736             object     => 'domain',
 737             attributes => {
 738                 domain                => $domain,
 739                 auto_renew            => 0,
 740                 handle                => 'process',
 741                 period                => $years,
 742                 currentexpirationyear => $expiration,
 743             }
 744         }
 745     );
 746     $self->_set_response;
 747     return $rv->{is_success};
 748 }
 749
 750 =item revoke_domain()
 751
 752 Revoke a previously registered domain.  This only works if the domain is
 753 still within the grace period as defined by the registrar.
 754 Requires you to have called set_manage_auth() B<first>.
 755
 756  my $result = $srs->revoke_domain( 'example.com' );
 757
 758 Returns true if the revoke is successful, false otherwise.
 759 Returns undefined on error.
 760
 761 =cut
 762
 763 sub revoke_domain
 764 {
 765     my ($self, $domain) = @_;
 766     return undef unless $domain;
 767     unless ($self->{config}->{username}) {
 768         $self->debug("Management auth not set.");
 769         return undef;
 770     }
 771     $rv = $self->make_request(
 772         {
 773             action     => 'revoke',
 774             object     => 'domain',
 775             attributes => {
 776                 reseller => $self->{config}->{username},
 777                 domain => $domain,
 778             }
 779         }
 780     );
 781     $self->_set_response;
 782     return $rv->{is_success};
 783 }
 784
 785 =item transfer_domain()
 786
 787  my $result = $srs->transfer_domain( 'example.com', $c );
 788
 789 Transfer a domain under your control.
 790 Returns true on success, false on failure, and undefined on caller error.
 791
 792 =cut
 793
 794 sub transfer_domain
 795 {
 796     my $self = shift;
 797     return $self->register_domain( @_, 1 );
 798 }
 799
 800 =item make_request()
 801
 802 This method is the real workhorse of this module.  If any OpenSRS API
 803 isn't explicity implemented in this module as a method call (such as
 804 get_cookie(), bulk_lock(), etc), you can use make_request() to build and send
 805 the API yourself.
 806
 807 Examples:
 808
 809  my $result = $srs->make_request(
 810      {
 811          batch   => 1,
 812          action  => 'submit',
 813          object  => 'bulk_change',
 814          attributes => {
 815              change_type => 'domain_lock',
 816              change_items => [ 'example.com', 'example.net' ],
 817              op_type => 'lock',
 818          }
 819      }
 820  );
 821
 822  my $result = $srs->make_request(
 823      {
 824          action     => 'lookup',
 825          object     => 'domain',
 826          attributes => {
 827              domain => 'example.com'
 828          }
 829      }
 830  );
 831
 832 Returns a hashref containing parsed XML results from OpenSRS.
 833
 834 Example return:
 835
 836  {
 837      'protocol' => 'XCP',
 838      'object' => 'DOMAIN',
 839      'response_text' => 'Domain taken',
 840      'action' => 'REPLY',
 841      'response_code' => '211',
 842      'attributes' => {
 843          'status' => 'taken',
 844          'match' => {}
 845      },
 846      'is_success' => '1'
 847  }
 848
 849 =cut
 850
 851 # build opensrs xml protocol string.  submit.
 852 # convert xml response to data structure, and return.
 853 sub make_request
 854 {
 855     my ($self, $data) = @_;
 856     return undef unless ref $data;
 857
 858     $self->debug("Using " . $self->environment . " environment.");
 859
 860     my $key  = $self->{config}->{ $self->environment }->{key};
 861     my $host = $self->{config}->{ $self->environment }->{host};
 862     $ENV{HTTPS_DEBUG} = 1 if $self->debug_level > 2;
 863
 864     unless ($key) {
 865         $self->debug("Authentication key not set.");
 866         return undef;
 867     }
 868
 869     my $action = uc $data->{action};
 870     my $object = uc $data->{object};
 871
 872     # build our XML request.
 873     # lets not bother with anything super fancy,
 874     # everything but the item keys are always static anyway.
 875     my $xml;
 876     $xml = <<XML;
 877 <?xml version='1.0' encoding="UTF-8" standalone="no" ?>
 878 <!DOCTYPE OPS_envelope SYSTEM "ops.dtd">
 879 <OPS_envelope>
 880 <header><version>0.9</version></header>
 881 <body>
 882 <data_block>
 883 <dt_assoc>
 884   <item key="protocol">XCP</item>
 885   <item key="action">$action</item>
 886   <item key="object">$object</item>
 887 XML
 888
 889     $xml .= "  <item key=\"cookie\">$data->{cookie}</item>\n" if $data->{cookie};
 890
 891 $xml .= <<XML;
 892   <item key="attributes">
 893     <dt_assoc>
 894 XML
 895
 896     foreach (sort keys %{ $data->{attributes} }) {
 897         my $val = $data->{attributes}->{$_};
 898         $xml .= $self->_format( $val, 4 );
 899     }
 900     $xml .= <<XML;
 901     </dt_assoc>
 902   </item>
 903 </dt_assoc>
 904 </data_block>
 905 </body>
 906 </OPS_envelope>
 907 XML
 908
 909     # whoof, ok.  got our request built.  lets ship it off.
 910     if ($self->debug_level > 1) {
 911         $self->debug("\nClient Request XML:\n" . '-' x 30);
 912         $self->debug($xml);
 913     }
 914
 915     $host = $self->{config}->{bulkhost} if $data->{batch};
 916     $self->debug("Making request to $host...");
 917     my $ua = LWP::UserAgent->new( timeout => 20, agent => "Net::OpenSRS/$VERSION" );
 918     unless ($ua) {
 919         $self->debug("Unable to contact remote host.");
 920         return undef;
 921     }
 922
 923     my $res = $ua->post(
 924         $host,
 925         'Content-Type' => 'text/xml',
 926         'X-Username'   => $self->{config}->{username},
 927         'X-Signature'  => hash( hash( $xml, $key ), $key ),
 928         'Content'      => $xml
 929     );
 930
 931     my $struct;
 932     if ( $res->is_success ) {
 933         $self->debug("HTTP result: " . $res->status_line);
 934         my $rslt = $res->content;
 935         # OpenSRS renew response triggers Expat parser error due to spaces in element name
 936         $rslt =~ s/registration expiration date/registration_expiration_date/g;
 937
 938         eval { $struct = XML::Simple::XMLin(
 939                  $rslt,
 940                  'KeyAttr' => [ 'dt_assoc' ],
 941                  'GroupTags' => { 'dt_assoc' => 'item',  'dt_array' => 'item' },
 942                );
 943         };
 944
 945         if ($self->debug_level > 1) {
 946             $self->debug("\nOpenSRS Response XML:\n" . '-' x 30);
 947             $self->debug($res->content);
 948             $self->debug('');
 949         }
 950
 951         # get the struct looking just how we want it.
 952         # (de-nastify it.)
 953         (undef, $struct) = _denastify( $struct->{body}->{data_block} );
 954     }
 955     else {
 956         $self->debug("HTTP error: " . $res->status_line);
 957         return undef;
 958     }
 959
 960     $rv = $struct;
 961     $self->_set_response;
 962     return $self->last_response(1);
 963 }
 964
 965 # encode special characters
 966
 967 my %encode_hash = (
 968   '<' => '&lt;',
 969   '>' => '&gt;',
 970   "'" => '&apos;',
 971   '"' => '&quot;',
 972   '&' => '&amp;',
 973 );
 974
 975 sub _encode
 976 {
 977   my $arg = shift;
 978   return $arg unless ($arg =~/\<|\>|\'|\"|\&/);
 979   $arg =~ s/(\<|\>|\'|\"|\&)/$encode_hash{$1}/ge;
 980   $arg
 981 }
 982
 983 # format perl structs into opensrs XML
 984 sub _format
 985 {
 986     my ($self, $val, $indent) = @_;
 987     my $xml;
 988
 989     $indent ||= 6;
 990     my $sp = ' ' x $indent;
 991
 992     if ( ref $val eq 'ARRAY' ) {
 993         my $c = 0;
 994         $xml .= "$sp<item key=\"$_\">\n";
 995         $xml .= "$sp  <dt_array>\n";
 996         foreach (map { _encode($_) } sort @$val) {
 997 #            $xml .= "$sp    <item key=\"$c\">$_</item>\n";
 998             $xml .= "$sp    <item key=\"$c\">\n";
 999             $xml .= $self->_format($_);
1000             $xml .= "$sp    </item>\n";
1001             $c++;
1002         }
1003         $xml .= "$sp  </dt_array>\n";
1004         $xml .= "$sp</item>\n";
1005     }
1006
1007     elsif ( ref $val eq 'HASH' ) {
1008         $xml .= "$sp<item key=\"$_\">\n" unless /^HASH/;
1009         $xml .= "$sp<dt_assoc>\n";
1010         foreach (sort keys %$val) {
1011             $xml .= $self->_format( $val->{$_} );
1012         }
1013         $xml .= "$sp</dt_assoc>\n";
1014         $xml .= "$sp</item>\n" unless /^HASH/;
1015     }
1016
1017     else {
1018         $val = _encode($val);
1019         $xml .= "$sp<item key=\"$_\">$val</item>\n";
1020     }
1021
1022     return $xml;
1023 }
1024
1025 sub _denastify {
1026     my ($arg) = ( shift );
1027
1028     if ( 0 ) {
1029       eval { use Data::Dumper };
1030       warn $@ if $@;
1031       warn "_denastify\n". Dumper($arg) unless $@;
1032     }
1033
1034     if ( ref($arg) eq 'HASH' ) {
1035         my $value;
1036         if ( exists( $arg->{content} ) ) {
1037             $value = $arg->{content};
1038         } elsif ( exists( $arg->{dt_array} ) ) {
1039             my $array = $arg->{dt_array};
1040             $array = [ $array ] unless ref($array) eq 'ARRAY';
1041             $value = [ map {
1042                                { map { _denastify($_) } @{ $_->{dt_assoc} } }
1043                            }
1044                        @$array
1045                      ];
1046         } elsif ( exists( $arg->{dt_assoc} ) ) {
1047             my $array = $arg->{dt_assoc};
1048             $array = [ $array ] unless ref($array) eq 'ARRAY';
1049             $value = { map { _denastify($_) } @$array };
1050         }
1051         return ( $arg->{key} => $value );
1052     }
1053     ();
1054 }
1055
1056 sub _parse_phone {
1057   require Number::Phone;
1058   my ($phone) = shift;
1059   my ($country, $idd) = Number::Phone::Country::phone2country_and_idd($phone);
1060   return undef unless $country;
1061   my $np = Number::Phone->new($phone);
1062   $np = Number::Phone->new($country, $phone) unless defined $np;
1063   return undef unless defined $np;
1064   (my $epp = $np->format) =~ s/\s+/\./;
1065   $epp =~ s/\s+//g;
1066   return $epp;
1067 }
1068
1069 =back
1070
1071 =head1 Author
1072
1073 Original author: Mahlon E. Smith I<mahlon@martini.nu> for Spime Solutions Group
1074 I<(www.spime.net)>
1075
1076 Contributors: Sten Spans, Jeff Finucane and Richard Siddall for Freeside
1077 Internet Services I<(www.freeside.biz)>, Justin Hunter.
1078
1079 Current maintainer: Ivan Kohler <ivan-opensrs@freeside.biz>
1080
1081 =cut
1082
1083 1;