FS/FS/part_export/domreg_net_dri.pm

   1 package FS::part_export::domreg_net_dri;
   2
   3 use vars qw(@ISA %info %options $conf);
   4 use Tie::IxHash;
   5 use FS::part_export::null;
   6
   7 =head1 NAME
   8
   9 FS::part_export::domreg_net_dri - Register or transfer domains with Net::DRI
  10
  11 =head1 DESCRIPTION
  12
  13 This module handles registering and transferring domains with select registrars or registries supported
  14 by L<Net::DRI>.
  15
  16 As a part_export, this module can be designated for use with svc_domain services.  When the svc_domain object
  17 is inserted into the Freeside database, registration or transferring of the domain may be initiated, depending
  18 on the setting of the svc_domain's action field.  Further operations can be performed from the View Domain screen.
  19
  20 Logging information is written to the Freeside log folder.
  21
  22 For correct operation you must add name/value pairs to the protcol and transport options fields.  The setttings
  23 depend on the domain registry driver (DRD) selected.
  24
  25 =over 4
  26
  27 =item N - Register the domain
  28
  29 =item M - Transfer the domain
  30
  31 =item I - Ignore the domain for registration purposes
  32
  33 =back
  34
  35 =cut
  36
  37 @ISA = qw(FS::part_export::null);
  38
  39 my @tldlist = qw/com net org biz info name mobi at be ca cc ch cn de dk es eu fr it mx nl tv uk us/;
  40
  41 my $opensrs_protocol_opts=<<'END';
  42 username=
  43 password=
  44 auto_renew=0
  45 affiliate_id=
  46 reseller_id=
  47 END
  48
  49 my $opensrs_transport_opts=<<'END';
  50 client_login=
  51 client_password=
  52 END
  53
  54 tie %options, 'Tie::IxHash',
  55   'drd'            => { label  => 'Domain Registry Driver (DRD)',
  56                       type => 'select',
  57                       options => [ qw/BookMyName CentralNic Gandi OpenSRS OVH VNDS/ ],
  58                       default => 'OpenSRS' },
  59   'log_level'  => { label  => 'Logging',
  60                       type => 'select',
  61                       options => [ qw/debug info notice warning error critical alert emergency/ ],
  62                       default => 'warning' },
  63   'protocol_opts'  => {
  64                       label   => 'Protocol Options',
  65                       type    => 'textarea',
  66                       default => $opensrs_protocol_opts,
  67                       },
  68   'transport_opts' => {
  69                       label   => 'Transport Options',
  70                       type    => 'textarea',
  71                       default => $opensrs_transport_opts,
  72                       },
  73 #  'register'       => { label => 'Use for registration',
  74 #                      type => 'checkbox',
  75 #                      default => '1' },
  76 #  'transfer'       => { label => 'Use for transfer',
  77 #                      type => 'checkbox',
  78 #                      default => '1' },
  79 #  'delete'         => { label => 'Use for deletion',
  80 #                      type => 'checkbox',
  81 #                      default => '1' },
  82 #  'renew'          => { label => 'Use for renewals',
  83 #                      type => 'checkbox',
  84 #                      default => '1' },
  85   'tlds'           => { label => 'Use this export for these top-level domains (TLDs)',
  86                       type => 'select',
  87                       multi => 1,
  88                       size => scalar(@tldlist),
  89                       options => [ @tldlist ],
  90                       default => 'com net org' },
  91 ;
  92
  93 my $opensrs_protocol_defaults = $opensrs_protocol_opts;
  94 $opensrs_protocol_defaults =~ s|\n|\\n|g;
  95
  96 my $opensrs_transport_defaults = $opensrs_transport_opts;
  97 $opensrs_transport_defaults =~ s|\n|\\n|g;
  98
  99 %info = (
 100   'svc'     => 'svc_domain',
 101   'desc'    => 'Domain registration via Net::DRI',
 102   'options' => \%options,
 103   'notes'   => <<"END"
 104 Registers and transfers domains via a Net::DRI registrar or registry.
 105 <a href="http://search.cpan.org/search?dist=Net-DRI">Net::DRI</a>
 106 must be installed.  You must have an account at the selected registrar/registry.
 107 <BR />
 108 Some top-level domains have additional business rules not supported by this export. These TLDs cannot be registered or transfered with this export.
 109 <BR><BR>Use these buttons for some useful presets:
 110 <UL>
 111   <LI>
 112     <INPUT TYPE="button" VALUE="OpenSRS Live System (rr-n1-tor.opensrs.net)" onClick='
 113       document.dummy.machine.value = "rr-n1-tor.opensrs.net";
 114       this.form.machine.value = "rr-n1-tor.opensrs.net";
 115     '>
 116   <LI>
 117     <INPUT TYPE="button" VALUE="OpenSRS Test System (horizon.opensrs.net)" onClick='
 118       document.dummy.machine.value = "horizon.opensrs.net";
 119       this.form.machine.value = "horizon.opensrs.net";
 120     '>
 121   <LI>
 122     <INPUT TYPE="button" VALUE="OpenSRS protocol/transport options" onClick='
 123       this.form.protocol_opts.value = "$opensrs_protocol_defaults";
 124       this.form.transport_opts.value = "$opensrs_transport_defaults";
 125     '>
 126 </UL>
 127 END
 128 );
 129
 130 install_callback FS::UID sub {
 131   $conf = new FS::Conf;
 132 };
 133
 134 #sub rebless { shift; }
 135
 136 # experiment: want the status of these right away, so no queueing
 137
 138 sub _export_insert {
 139   my( $self, $svc_domain ) = ( shift, shift );
 140
 141   return if $svc_domain->action eq 'I';  # Ignoring registration, just doing DNS
 142
 143   if ($svc_domain->action eq 'N') {
 144     return $self->register( $svc_domain );
 145   } elsif ($svc_domain->action eq 'M') {
 146     return $self->transfer( $svc_domain );
 147   }
 148   return "Unknown domain action " . $svc_domain->action;
 149 }
 150
 151 =item get_portfolio_credentials
 152
 153 Returns, in list context, the user name and password for the domain portfolio.
 154
 155 This is currently specified via the username and password keys in the protocol options.
 156
 157 =cut
 158
 159 sub get_portfolio_credentials {
 160   my $self = shift;
 161
 162   my %opts = $self->get_protocol_options();
 163   return ($opts{username}, $opts{password});
 164 }
 165
 166 =item format_tel
 167
 168 Reformats a phone number according to registry rules.  Currently Freeside stores phone numbers
 169 in NANPA format and most registries prefer "+CCC.NPANPXNNNN"
 170
 171 =cut
 172
 173 sub format_tel {
 174   my $tel = shift;
 175
 176   #if ($tel =~ /^(\d{3})-(\d{3})-(\d{4})\s*(x\s*(\d+))?$/) {
 177   if ($tel =~ /^(\d{3})-(\d{3})-(\d{4})$/) {
 178     $tel = "+1.$1$2$3"; # TBD: other country codes
 179 #    if $tel .= "$4" if $4;
 180   }
 181   return $tel;
 182 }
 183
 184 sub gen_contact_set {
 185   my ($self, $dri, $cust_main) = @_;
 186
 187   my @invoicing_list = $cust_main->invoicing_list_emailonly;
 188   if ( $conf->exists('emailinvoiceautoalways')
 189        || $conf->exists('emailinvoiceauto') && ! @invoicing_list
 190        || ( $conf->exists('emailinvoiceonly') && ! @invoicing_list ) ) {
 191     push @invoicing_list, $cust_main->all_emails;
 192   }
 193
 194   my $email = ($conf->exists('business-onlinepayment-email-override'))
 195               ? $conf->config('business-onlinepayment-email-override')
 196               : $invoicing_list[0];
 197
 198   my $cs=$dri->local_object('contactset');
 199   my $co=$dri->local_object('contact');
 200
 201   my ($user, $pass) = $self->get_portfolio_credentials();
 202
 203   $co->srid($user);     # Portfolio user name for OpenSRS?
 204   $co->auth($pass);     # Portfolio password for OpenSRS?
 205
 206   $co->firstname($cust_main->first);
 207   $co->name($cust_main->last);
 208   $co->org($cust_main->company || '-');
 209   $co->street([$cust_main->address1, $cust_main->address2]);
 210   $co->city($cust_main->city);
 211   $co->sp($cust_main->state);
 212   $co->pc($cust_main->zip);
 213   $co->cc($cust_main->country);
 214   $co->voice(format_tel($cust_main->daytime()));
 215   $co->email($email);
 216
 217   $cs->set($co, 'registrant');
 218   $cs->set($co, 'admin');
 219   $cs->set($co, 'billing');
 220
 221   return $cs;
 222 }
 223
 224 =item validate_contact_set
 225
 226 Attempts to validate contact data for the domain based on OpenSRS rules.
 227
 228 Returns undef if the contact data is acceptable, an error message if the contact
 229 data lacks one or more required fields.
 230
 231 =cut
 232
 233 sub validate_contact_set {
 234   my $c = shift;
 235
 236   my %fields = (
 237     firstname => "first name",
 238     name => "last name",
 239     street => "street address",
 240     city => "city",
 241     sp => "state",
 242     pc => "ZIP/postal code",
 243     cc => "country",
 244     email => "email address",
 245     voice => "phone number",
 246   );
 247   my @err = ();
 248   foreach my $which (qw/registrant admin billing/) {
 249     my $co = $c->get($which);
 250     foreach (keys %fields) {
 251       if (!$co->$_()) {
 252         push @err, $fields{$_};
 253       }
 254     }
 255   }
 256   if (scalar(@err) > 0) {
 257     return "Contact information needs: " . join(', ', @err);
 258   }
 259   undef;
 260 }
 261
 262 #sub _export_replace {
 263 #  my( $self, $new, $old ) = (shift, shift, shift);
 264 #
 265 #  return '';
 266 #
 267 #}
 268
 269 ## Domain registration exports do nothing on delete.  You're just removing the domain from Freeside, not the registry
 270 #sub _export_delete {
 271 #  my( $self, $www ) = ( shift, shift );
 272 #
 273 #  return '';
 274 #}
 275
 276 =item split_textarea_options
 277
 278 Split textarea contents into lines, split lines on =, and then trim the results;
 279
 280 =cut
 281
 282 sub split_textarea_options {
 283   my ($self, $optname) = @_;
 284   my %opts =  map {
 285     my ($key, $value) = split /=/, $_;
 286     $key =~ s/^\s*//;
 287     $key =~ s/\s*$//;
 288     $value =~ s/^\s*//;
 289     $value =~ s/\s*$//;
 290     $key => $value } split /\n/, $self->option($optname);
 291   %opts;
 292 }
 293
 294 =item get_protocol_options
 295
 296 Return a hash of protocol options
 297
 298 =cut
 299
 300 sub get_protocol_options {
 301   my $self = shift;
 302   my %opts = $self->split_textarea_options('protocol_opts');
 303   if ($self->machine =~ /opensrs\.net/) {
 304    my %topts = $self->get_transport_options;
 305    $opts{reseller_id} = $topts{client_login};
 306   }
 307   %opts;
 308 }
 309
 310 =item get_transport_options
 311
 312 Return a hash of transport options
 313
 314 =cut
 315
 316 sub get_transport_options {
 317   my $self = shift;
 318   my %opts = $self->split_textarea_options('transport_opts');
 319   $opts{remote_url} = "https://" . $self->machine . ":55443/resellers" if $self->machine =~ /opensrs\.net/;
 320   %opts;
 321 }
 322
 323 =item is_supported_domain
 324
 325 Return undef if the domain name uses a TLD or SLD that is supported by this registrar.
 326 Otherwise return an error message explaining what's wrong.
 327
 328 =cut
 329
 330 sub is_supported_domain {
 331   my $self = shift;
 332   my $svc_domain = shift;
 333
 334   # Get the TLD of the new domain
 335   my @bits = split /\./, $svc_domain->domain;
 336
 337   return "Can't register subdomains: " . $svc_domain->domain if scalar(@bits) != 2;
 338
 339   my $tld = pop @bits;
 340
 341   # See if it's one this export supports
 342   my @tlds = split /\s+/, $self->option('tlds');
 343   @tlds =  map { s/\.//; $_ } @tlds;
 344   return "Can't register top-level domain $tld, restricted to: " . $self->option('tlds') if ! grep { $_ eq $tld } @tlds;
 345   return undef;
 346 }
 347
 348 =item get_dri
 349
 350 =cut
 351
 352 sub get_dri {
 353   my $self = shift;
 354   my $dri;
 355
 356 #  return $self->{dri} if $self->{dri}; #!!!TBD!!! connection caching.
 357
 358   eval "use Net::DRI 0.95;";
 359   return $@ if $@;
 360
 361 # $dri=Net::DRI->new(...) to create the global object. Save the result,
 362
 363   eval {
 364     #$dri = Net::DRI::TrapExceptions->new(10);
 365     $dri = Net::DRI->new({logging => [ 'files', { output_directory => '%%%FREESIDE_LOG%%%' } ]}); #!!!TBD!!!
 366     $dri->logging->level( $self->option('log_level') );
 367     $dri->add_registry( $self->option('drd') );
 368     my $protocol;
 369     $protocol = 'xcp' if $self->option('drd') eq 'OpenSRS';
 370
 371     $dri->target( $self->option('drd') )->add_current_profile($self->option('drd') . '1',
 372 #      'Net::DRI::Protocol::' . $self->option('protocol_type'),
 373 #      $self->option('protocol_type'),
 374 #       'xcp', #TBD!!!!
 375         $protocol, # Implies transport
 376 #      'Net::DRI::Transport::' . $self->option('transport_type'),
 377       { $self->get_transport_options() },
 378 #      [ $self->get_protocol_options() ]
 379       );
 380   };
 381   return $@ if $@;
 382
 383   $self->{dri} = $dri;
 384   return $dri;
 385 }
 386
 387 =item get_status
 388
 389 Returns a reference to a hashref containing information on the domain's status.  The keys
 390 defined depend on the status.
 391
 392 'unregistered' means the domain is not registered.
 393
 394 Otherwise, if the domain is in an asynchronous operation such as a transfer, returns the state
 395 of that operation.
 396
 397 Otherwise returns a value indicating if the domain can be managed through our reseller account.
 398
 399 =cut
 400
 401 sub get_status {
 402   my ( $self, $svc_domain ) = @_;
 403   my $rc;
 404   my $rslt = {};
 405
 406   my $dri = $self->get_dri;
 407
 408     if (UNIVERSAL::isa($dri, 'Net::DRI::Exception')) {
 409       $rslt->{'message'} = $dri->as_string;
 410       return $rslt;
 411     }
 412   eval {
 413     $rc = $dri->domain_check( $svc_domain->domain );
 414     if (!$rc->is_success()) {
 415       # Problem accessing the registry/registrar
 416       $rslt->{'message'} = $rc->message;
 417     } elsif (!$dri->get_info('exist')) {
 418       # Domain is not registered
 419       $rslt->{'unregistered'} = 1;
 420     } else {
 421       $rc = $dri->domain_transfer_query( $svc_domain->domain );
 422       if ($rc->is_success() && $dri->get_info('status')) {
 423         # Transfer in progress
 424         $rslt->{status} = $dri->get_info('status');
 425         $rslt->{contact_email} = $dri->get_info('request_address');
 426         $rslt->{last_update_time} = $dri->get_info('unixtime');
 427       } elsif ($dri->get_info('reason')) {
 428         $rslt->{'reason'} = $dri->get_info('reason');
 429         # Domain is not being transferred...
 430         $rc = $dri->domain_info( $svc_domain->domain, { $self->get_protocol_options() } );
 431         if ($rc->is_success() && $dri->get_info('exDate')) {
 432             $rslt->{'expdate'} = $dri->get_info('exDate');
 433         }
 434       } else {
 435         $rslt->{status} = 'Unknown';
 436       }
 437     }
 438   };
 439 #  rslt->{'message'} = $@->as_string if $@;
 440   if ($@) {
 441     $rslt->{'message'} = (UNIVERSAL::isa($@, 'Net::DRI::Exception')) ? $@->as_string : $@->message;
 442   }
 443
 444   return $rslt; # Success
 445 }
 446
 447 =item register
 448
 449 Attempts to register the domain through the reseller account associated with this export.
 450
 451 Like most export functions, returns an error message on failure or undef on success.
 452
 453 =cut
 454
 455 sub register {
 456   my ( $self, $svc_domain, $years ) = @_;
 457
 458   my $err = $self->is_supported_domain( $svc_domain );
 459   return $err if $err;
 460
 461   my $dri = $self->get_dri;
 462   return $dri->as_string if (UNIVERSAL::isa($dri, 'Net::DRI::Exception'));
 463
 464   eval { # All $dri methods can throw an exception.
 465
 466 # Call methods
 467     my $cust_main = $svc_domain->cust_svc->cust_pkg->cust_main;
 468
 469     my $cs = $self->gen_contact_set($dri, $cust_main);
 470
 471     $err = validate_contact_set($cs);
 472     return $err if $err;
 473
 474 # !!!TBD!!! add custom name servers when supported; add ns => $ns to hash passed to domain_create
 475
 476     $res = $dri->domain_create($svc_domain->domain, { $self->get_protocol_options(), pure_create => 1, contact => $cs, duration => DateTime::Duration->new(years => $years) });
 477     $err = $res->is_success ? '' : $res->message;
 478   };
 479   if ($@) {
 480     $err = (UNIVERSAL::isa($@, 'Net::DRI::Exception')) ? $@->msg : $@->message;
 481   }
 482
 483   return $err;
 484 }
 485
 486 =item transfer
 487
 488 Attempts to transfer the domain into the reseller account associated with this export.
 489
 490 Like most export functions, returns an error message on failure or undef on success.
 491
 492 =cut
 493
 494 sub transfer {
 495   my ( $self, $svc_domain ) = @_;
 496
 497   my $err = $self->is_supported_domain( $svc_domain );
 498   return $err if $err;
 499
 500 # $dri=Net::DRI->new(...) to create the global object. Save the result,
 501   my $dri = $self->get_dri;
 502   return $dri->as_string if (UNIVERSAL::isa($dri, 'Net::DRI::Exception'));
 503
 504   eval { # All $dri methods can throw an exception
 505
 506 # Call methods
 507     my $cust_main = $svc_domain->cust_svc->cust_pkg->cust_main;
 508
 509     my $cs = $self->gen_contact_set($dri, $cust_main);
 510
 511     $err = validate_contact_set($cs);
 512     return $err if $err;
 513
 514 # !!!TBD!!! add custom name servers when supported; add ns => $ns to hash passed to domain_transfer_start
 515
 516     $res = $dri->domain_transfer_start($svc_domain->domain, { $self->get_protocol_options(), contact => $cs });
 517     $err = $res->is_success ? '' : $res->message;
 518   };
 519   if ($@) {
 520     $err = (UNIVERSAL::isa($@, 'Net::DRI::Exception')) ? $@->msg : $@->message;
 521   }
 522
 523   return $err;
 524 }
 525
 526 =item renew
 527
 528 Attempts to renew the domain for the specified number of years.
 529
 530 Like most export functions, returns an error message on failure or undef on success.
 531
 532 =cut
 533
 534 sub renew {
 535   my ( $self, $svc_domain, $years ) = @_;
 536
 537   my $err = $self->is_supported_domain( $svc_domain );
 538   return $err if $err;
 539
 540   my $dri = $self->get_dri;
 541   return $dri->as_string if (UNIVERSAL::isa($dri, 'Net::DRI::Exception'));
 542
 543   eval { # All $dri methods can throw an exception
 544     my $expdate;
 545     my $res = $dri->domain_info( $svc_domain->domain, { $self->get_protocol_options() } );
 546     if ($res->is_success() && $dri->get_info('exDate')) {
 547       $expdate = $dri->get_info('exDate');
 548
 549 #    return "Domain renewal not enabled" if !$self->option('renew');
 550       $res = $dri->domain_renew( $svc_domain->domain, { $self->get_protocol_options(), duration => DateTime::Duration->new(years => $years), current_expiration => $expdate });
 551     }
 552     $err = $res->is_success ? '' : $res->message;
 553   };
 554   if ($@) {
 555     $err = (UNIVERSAL::isa($@, 'Net::DRI::Exception')) ? $@->msg : $@->message;
 556   }
 557
 558   return $err;
 559 }
 560
 561 =item revoke
 562
 563 Attempts to revoke the domain registration.  Only succeeds if invoked during the DRI
 564 grace period immediately after registration.
 565
 566 Like most export functions, returns an error message on failure or undef on success.
 567
 568 =cut
 569
 570 sub revoke {
 571   my ( $self, $svc_domain ) = @_;
 572
 573   my $err = $self->is_supported_domain( $svc_domain );
 574   return $err if $err;
 575
 576   my $dri = $self->get_dri;
 577   return $dri->as_string if (UNIVERSAL::isa($dri, 'Net::DRI::Exception'));
 578
 579   eval { # All $dri methods can throw an exception
 580
 581 #    return "Domain registration revocation not enabled" if !$self->option('revoke');
 582     my $res = $dri->domain_delete( $svc_domain->domain, { $self->get_protocol_options(), domain => $svc_domain->domain, pure_delete => 1 });
 583     $err = $res->is_success ? '' : $res->message;
 584   };
 585   if ($@) {
 586     $err = (UNIVERSAL::isa($@, 'Net::DRI::Exception')) ? $@->msg : $@->message;
 587   }
 588
 589   return $err;
 590 }
 591
 592 =item registrar
 593
 594 Should return a full-blown object representing the Net::DRI DRD, but current just returns a hashref
 595 containing the registrar name.
 596
 597 =cut
 598
 599 sub registrar {
 600   my $self = shift;
 601   return {
 602         name => $self->option('drd'),
 603   };
 604 }
 605
 606 =head1 SEE ALSO
 607
 608 L<FS::part_export_option>, L<FS::export_svc>, L<FS::svc_domain>,
 609 L<FS::Record>, schema.html from the base documentation.
 610
 611 =cut
 612
 613 1;
 614