path: root/FS/FS/part_export/domreg_net_dri.pm

package FS::part_export::domreg_net_dri;

use vars qw(@ISA %info %options $conf);
use Tie::IxHash;
use FS::part_export::null;

=head1 NAME

FS::part_export::domreg_net_dri - Register or transfer domains with Net::DRI

=head1 DESCRIPTION

This module handles registering and transferring domains with select registrars or registries supported
by L<Net::DRI>.

As a part_export, this module can be designated for use with svc_domain services.  When the svc_domain object
is inserted into the Freeside database, registration or transferring of the domain may be initiated, depending
on the setting of the svc_domain's action field.  Further operations can be performed from the View Domain screen.

Logging information is written to the Freeside log folder.

For correct operation you must add name/value pairs to the protcol and transport options fields.  The setttings
depend on the domain registry driver (DRD) selected.

=over 4

=item N - Register the domain

=item M - Transfer the domain

=item I - Ignore the domain for registration purposes

=back

=cut

@ISA = qw(FS::part_export::null);

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/;

my $opensrs_protocol_opts=<<'END';
username=
password=
auto_renew=0
affiliate_id=
reseller_id=
END

my $opensrs_transport_opts=<<'END';
client_login=
client_password=
END

tie %options, 'Tie::IxHash',
  'drd'            => { label  => 'Domain Registry Driver (DRD)',
                      type => 'select',
                      options => [ qw/BookMyName CentralNic Gandi OpenSRS OVH VNDS/ ],
                      default => 'OpenSRS' },
  'log_level'  => { label  => 'Logging',
                      type => 'select',
		      options => [ qw/debug info notice warning error critical alert emergency/ ],
                      default => 'warning' },
  'protocol_opts'  => {
                      label   => 'Protocol Options',
                      type    => 'textarea',
                      default => $opensrs_protocol_opts,
                      },
  'transport_opts' => {
                      label   => 'Transport Options',
                      type    => 'textarea',
                      default => $opensrs_transport_opts,
                      },
#  'register'       => { label => 'Use for registration',
#                      type => 'checkbox',
#                      default => '1' },
#  'transfer'       => { label => 'Use for transfer',
#                      type => 'checkbox',
#                      default => '1' },
#  'delete'         => { label => 'Use for deletion',
#                      type => 'checkbox',
#                      default => '1' },
#  'renew'          => { label => 'Use for renewals',
#                      type => 'checkbox',
#                      default => '1' },
  'tlds'           => { label => 'Use this export for these top-level domains (TLDs)',
                      type => 'select',
                      multi => 1,
                      size => scalar(@tldlist),
                      options => [ @tldlist ],
                      default => 'com net org' },
;

my $opensrs_protocol_defaults = $opensrs_protocol_opts;
$opensrs_protocol_defaults =~ s|\n|\\n|g;

my $opensrs_transport_defaults = $opensrs_transport_opts;
$opensrs_transport_defaults =~ s|\n|\\n|g;

%info = (
  'svc'     => 'svc_domain',
  'desc'    => 'Domain registration via Net::DRI',
  'options' => \%options,
  'notes'   => <<"END"
Registers and transfers domains via a Net::DRI registrar or registry.
<a href="http://search.cpan.org/search?dist=Net-DRI">Net::DRI</a>
must be installed.  You must have an account at the selected registrar/registry.
<BR />
Some top-level domains have additional business rules not supported by this export. These TLDs cannot be registered or transfered with this export.
<BR><BR>Use these buttons for some useful presets:
<UL>
  <LI>
    <INPUT TYPE="button" VALUE="OpenSRS Live System (rr-n1-tor.opensrs.net)" onClick='
      document.dummy.machine.value = "rr-n1-tor.opensrs.net";
      this.form.machine.value = "rr-n1-tor.opensrs.net";
    '>
  <LI>
    <INPUT TYPE="button" VALUE="OpenSRS Test System (horizon.opensrs.net)" onClick='
      document.dummy.machine.value = "horizon.opensrs.net";
      this.form.machine.value = "horizon.opensrs.net";
    '>
  <LI>
    <INPUT TYPE="button" VALUE="OpenSRS protocol/transport options" onClick='
      this.form.protocol_opts.value = "$opensrs_protocol_defaults";
      this.form.transport_opts.value = "$opensrs_transport_defaults";
    '>
</UL>
END
);

install_callback FS::UID sub {
  $conf = new FS::Conf;
};

#sub rebless { shift; }

# experiment: want the status of these right away, so no queueing

sub _export_insert {
  my( $self, $svc_domain ) = ( shift, shift );

  return if $svc_domain->action eq 'I';  # Ignoring registration, just doing DNS

  if ($svc_domain->action eq 'N') {
    return $self->register( $svc_domain );
  } elsif ($svc_domain->action eq 'M') {
    return $self->transfer( $svc_domain );
  }
  return "Unknown domain action " . $svc_domain->action;
}

=item get_portfolio_credentials

Returns, in list context, the user name and password for the domain portfolio.

This is currently specified via the username and password keys in the protocol options.

=cut

sub get_portfolio_credentials {
  my $self = shift;

  my %opts = $self->get_protocol_options();
  return ($opts{username}, $opts{password});
}

=item format_tel

Reformats a phone number according to registry rules.  Currently Freeside stores phone numbers
in NANPA format and most registries prefer "+CCC.NPANPXNNNN"

=cut

sub format_tel {
  my $tel = shift;

  #if ($tel =~ /^(\d{3})-(\d{3})-(\d{4})\s*(x\s*(\d+))?$/) {
  if ($tel =~ /^(\d{3})-(\d{3})-(\d{4})$/) {
    $tel = "+1.$1$2$3"; # TBD: other country codes
#    if $tel .= "$4" if $4;
  }
  return $tel;
}

sub gen_contact_set {
  my ($self, $dri, $cust_main) = @_;

  my @invoicing_list = $cust_main->invoicing_list_emailonly;
  if ( $conf->exists('emailinvoiceautoalways')
       || $conf->exists('emailinvoiceauto') && ! @invoicing_list
       || ( $conf->exists('emailinvoiceonly') && ! @invoicing_list ) ) {
    push @invoicing_list, $cust_main->all_emails;
  }

  my $email = ($conf->exists('business-onlinepayment-email-override'))
              ? $conf->config('business-onlinepayment-email-override')
              : $invoicing_list[0];

  my $cs=$dri->local_object('contactset');
  my $co=$dri->local_object('contact');

  my ($user, $pass) = $self->get_portfolio_credentials();

  $co->srid($user);	# Portfolio user name for OpenSRS?
  $co->auth($pass);	# Portfolio password for OpenSRS?

  $co->firstname($cust_main->first);
  $co->name($cust_main->last);
  $co->org($cust_main->company || '-');
  $co->street([$cust_main->address1, $cust_main->address2]);
  $co->city($cust_main->city);
  $co->sp($cust_main->state);
  $co->pc($cust_main->zip);
  $co->cc($cust_main->country);
  $co->voice(format_tel($cust_main->daytime()));
  $co->email($email);

  $cs->set($co, 'registrant');
  $cs->set($co, 'admin');
  $cs->set($co, 'billing');

  return $cs;
}

=item validate_contact_set

Attempts to validate contact data for the domain based on OpenSRS rules.

Returns undef if the contact data is acceptable, an error message if the contact
data lacks one or more required fields.

=cut

sub validate_contact_set {
  my $c = shift;

  my %fields = (
    firstname => "first name",
    name => "last name",
    street => "street address",
    city => "city",
    sp => "state",
    pc => "ZIP/postal code",
    cc => "country",
    email => "email address",
    voice => "phone number",
  );
  my @err = ();
  foreach my $which (qw/registrant admin billing/) {
    my $co = $c->get($which);
    foreach (keys %fields) {
      if (!$co->$_()) {
        push @err, $fields{$_};
      }
    }
  }
  if (scalar(@err) > 0) {
    return "Contact information needs: " . join(', ', @err);
  }
  undef;
}

#sub _export_replace {
#  my( $self, $new, $old ) = (shift, shift, shift);
#
#  return '';
#
#}

## Domain registration exports do nothing on delete.  You're just removing the domain from Freeside, not the registry
#sub _export_delete {
#  my( $self, $www ) = ( shift, shift );
#
#  return '';
#}

=item split_textarea_options

Split textarea contents into lines, split lines on =, and then trim the results;

=cut

sub split_textarea_options {
  my ($self, $optname) = @_;
  my %opts =  map {
    my ($key, $value) = split /=/, $_;
    $key =~ s/^\s*//;
    $key =~ s/\s*$//;
    $value =~ s/^\s*//;
    $value =~ s/\s*$//;
    $key => $value } split /\n/, $self->option($optname);
  %opts;
}

=item get_protocol_options

Return a hash of protocol options

=cut

sub get_protocol_options {
  my $self = shift;
  my %opts = $self->split_textarea_options('protocol_opts');
  if ($self->machine =~ /opensrs\.net/) {
   my %topts = $self->get_transport_options;
   $opts{reseller_id} = $topts{client_login};
  }
  %opts;
}

=item get_transport_options

Return a hash of transport options

=cut

sub get_transport_options {
  my $self = shift;
  my %opts = $self->split_textarea_options('transport_opts');
  $opts{remote_url} = "https://" . $self->machine . ":55443/resellers" if $self->machine =~ /opensrs\.net/;
  %opts;
}

=item is_supported_domain

Return undef if the domain name uses a TLD or SLD that is supported by this registrar.
Otherwise return an error message explaining what's wrong.

=cut

sub is_supported_domain {
  my $self = shift;
  my $svc_domain = shift;

  # Get the TLD of the new domain
  my @bits = split /\./, $svc_domain->domain;

  return "Can't register subdomains: " . $svc_domain->domain if scalar(@bits) != 2;

  my $tld = pop @bits;

  # See if it's one this export supports
  my @tlds = split /\s+/, $self->option('tlds');
  @tlds =  map { s/\.//; $_ } @tlds;
  return "Can't register top-level domain $tld, restricted to: " . $self->option('tlds') if ! grep { $_ eq $tld } @tlds;
  return undef;
}

=item get_dri

=cut

sub get_dri {
  my $self = shift;
  my $dri;

#  return $self->{dri} if $self->{dri}; #!!!TBD!!! connection caching.

  eval "use Net::DRI 0.95;";
  return $@ if $@;

# $dri=Net::DRI->new(...) to create the global object. Save the result,

  eval {
    #$dri = Net::DRI::TrapExceptions->new(10);
    $dri = Net::DRI->new({logging => [ 'files', { output_directory => '%%%FREESIDE_LOG%%%' } ]}); #!!!TBD!!!
    $dri->logging->level( $self->option('log_level') );
    $dri->add_registry( $self->option('drd') );
    my $protocol;
    $protocol = 'xcp' if $self->option('drd') eq 'OpenSRS';

    $dri->target( $self->option('drd') )->add_current_profile($self->option('drd') . '1',
#      'Net::DRI::Protocol::' . $self->option('protocol_type'),
#      $self->option('protocol_type'),
#	'xcp', #TBD!!!!
	$protocol, # Implies transport
#      'Net::DRI::Transport::' . $self->option('transport_type'),
      { $self->get_transport_options() },
#      [ $self->get_protocol_options() ]
      );
  };
  return $@ if $@;

  $self->{dri} = $dri;
  return $dri;
}

=item get_status

Returns a reference to a hashref containing information on the domain's status.  The keys
defined depend on the status.

'unregistered' means the domain is not registered.

Otherwise, if the domain is in an asynchronous operation such as a transfer, returns the state
of that operation.

Otherwise returns a value indicating if the domain can be managed through our reseller account.

=cut

sub get_status {
  my ( $self, $svc_domain ) = @_;
  my $rc;
  my $rslt = {};

  my $dri = $self->get_dri;

    if (UNIVERSAL::isa($dri, 'Net::DRI::Exception')) {
      $rslt->{'message'} = $dri->as_string;
      return $rslt;
    }
  eval {
    $rc = $dri->domain_check( $svc_domain->domain );
    if (!$rc->is_success()) {
      # Problem accessing the registry/registrar
      $rslt->{'message'} = $rc->message;
    } elsif (!$dri->get_info('exist')) {
      # Domain is not registered
      $rslt->{'unregistered'} = 1;
    } else {
      $rc = $dri->domain_transfer_query( $svc_domain->domain );
      if ($rc->is_success() && $dri->get_info('status')) {
        # Transfer in progress
      	$rslt->{status} = $dri->get_info('status');
	$rslt->{contact_email} = $dri->get_info('request_address');
	$rslt->{last_update_time} = $dri->get_info('unixtime');
      } elsif ($dri->get_info('reason')) {
	$rslt->{'reason'} = $dri->get_info('reason');
        # Domain is not being transferred...
        $rc = $dri->domain_info( $svc_domain->domain, { $self->get_protocol_options() } );
        if ($rc->is_success() && $dri->get_info('exDate')) {
            $rslt->{'expdate'} = $dri->get_info('exDate');
	}
      } else {
        $rslt->{status} = 'Unknown';
      }
    }
  };
#  rslt->{'message'} = $@->as_string if $@;
  if ($@) {
    $rslt->{'message'} = (UNIVERSAL::isa($@, 'Net::DRI::Exception')) ? $@->as_string : $@->message;
  }

  return $rslt; # Success
}

=item register

Attempts to register the domain through the reseller account associated with this export.

Like most export functions, returns an error message on failure or undef on success.

=cut

sub register {
  my ( $self, $svc_domain, $years ) = @_;

  my $err = $self->is_supported_domain( $svc_domain );
  return $err if $err;

  my $dri = $self->get_dri;
  return $dri->as_string if (UNIVERSAL::isa($dri, 'Net::DRI::Exception'));

  eval { # All $dri methods can throw an exception.

# Call methods
    my $cust_main = $svc_domain->cust_svc->cust_pkg->cust_main;

    my $cs = $self->gen_contact_set($dri, $cust_main);

    $err = validate_contact_set($cs);
    return $err if $err;

# !!!TBD!!! add custom name servers when supported; add ns => $ns to hash passed to domain_create

    $res = $dri->domain_create($svc_domain->domain, { $self->get_protocol_options(), pure_create => 1, contact => $cs, duration => DateTime::Duration->new(years => $years) });
    $err = $res->is_success ? '' : $res->message;
  };
  if ($@) {
    $err = (UNIVERSAL::isa($@, 'Net::DRI::Exception')) ? $@->msg : $@->message;
  }

  return $err;
}

=item transfer

Attempts to transfer the domain into the reseller account associated with this export.

Like most export functions, returns an error message on failure or undef on success.

=cut

sub transfer {
  my ( $self, $svc_domain ) = @_;

  my $err = $self->is_supported_domain( $svc_domain );
  return $err if $err;

# $dri=Net::DRI->new(...) to create the global object. Save the result,
  my $dri = $self->get_dri;
  return $dri->as_string if (UNIVERSAL::isa($dri, 'Net::DRI::Exception'));

  eval { # All $dri methods can throw an exception

# Call methods
    my $cust_main = $svc_domain->cust_svc->cust_pkg->cust_main;

    my $cs = $self->gen_contact_set($dri, $cust_main);

    $err = validate_contact_set($cs);
    return $err if $err;

# !!!TBD!!! add custom name servers when supported; add ns => $ns to hash passed to domain_transfer_start

    $res = $dri->domain_transfer_start($svc_domain->domain, { $self->get_protocol_options(), contact => $cs });
    $err = $res->is_success ? '' : $res->message;
  };
  if ($@) {
    $err = (UNIVERSAL::isa($@, 'Net::DRI::Exception')) ? $@->msg : $@->message;
  }

  return $err;
}

=item renew

Attempts to renew the domain for the specified number of years.

Like most export functions, returns an error message on failure or undef on success.

=cut

sub renew {
  my ( $self, $svc_domain, $years ) = @_;

  my $err = $self->is_supported_domain( $svc_domain );
  return $err if $err;

  my $dri = $self->get_dri;
  return $dri->as_string if (UNIVERSAL::isa($dri, 'Net::DRI::Exception'));

  eval { # All $dri methods can throw an exception
    my $expdate;
    my $res = $dri->domain_info( $svc_domain->domain, { $self->get_protocol_options() } );
    if ($res->is_success() && $dri->get_info('exDate')) {
      $expdate = $dri->get_info('exDate');

#    return "Domain renewal not enabled" if !$self->option('renew');
      $res = $dri->domain_renew( $svc_domain->domain, { $self->get_protocol_options(), duration => DateTime::Duration->new(years => $years), current_expiration => $expdate });
    }
    $err = $res->is_success ? '' : $res->message;
  };
  if ($@) {
    $err = (UNIVERSAL::isa($@, 'Net::DRI::Exception')) ? $@->msg : $@->message;
  }

  return $err;
}

=item revoke

Attempts to revoke the domain registration.  Only succeeds if invoked during the DRI
grace period immediately after registration.

Like most export functions, returns an error message on failure or undef on success.

=cut

sub revoke {
  my ( $self, $svc_domain ) = @_;

  my $err = $self->is_supported_domain( $svc_domain );
  return $err if $err;

  my $dri = $self->get_dri;
  return $dri->as_string if (UNIVERSAL::isa($dri, 'Net::DRI::Exception'));

  eval { # All $dri methods can throw an exception

#    return "Domain registration revocation not enabled" if !$self->option('revoke');
    my $res = $dri->domain_delete( $svc_domain->domain, { $self->get_protocol_options(), domain => $svc_domain->domain, pure_delete => 1 });
    $err = $res->is_success ? '' : $res->message;
  };
  if ($@) {
    $err = (UNIVERSAL::isa($@, 'Net::DRI::Exception')) ? $@->msg : $@->message;
  }

  return $err;
}

=item registrar

Should return a full-blown object representing the Net::DRI DRD, but current just returns a hashref
containing the registrar name.

=cut

sub registrar {
  my $self = shift;
  return {
  	name => $self->option('drd'),
  };
}

=head1 SEE ALSO

L<FS::part_export_option>, L<FS::export_svc>, L<FS::svc_domain>,
L<FS::Record>, schema.html from the base documentation.

=cut

1;