package FS::part_export::domreg_opensrs;
use vars qw(@ISA %info %options $conf $me $DEBUG);
use Tie::IxHash;
use DateTime;
use FS::Record qw(qsearchs qsearch);
use FS::Conf;
use FS::part_export::null;
use FS::svc_domain;
use FS::part_pkg;
=head1 NAME
FS::part_export::domreg_opensrs - Register or transfer domains with Tucows OpenSRS
=head1 DESCRIPTION
This module handles registering and transferring domains using a registration service provider (RSP) account
at Tucows OpenSRS, an ICANN-approved domain registrar.
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.
=over 4
=item N - Register the domain
=item M - Transfer the domain
=item I - Ignore the domain for registration purposes
=back
This export uses Net::OpenSRS. Registration and transfer attempts will fail unless Net::OpenSRS is installed
and LWP::UserAgent is able to make HTTPS posts. You can turn on debugging messages and use the OpenSRS test
gateway when setting up this export.
=cut
@ISA = qw(FS::part_export::null);
$me = '[' . __PACKAGE__ . ']';
$DEBUG = 0;
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 asn.au com.au id.au net.au org.au/;
tie %options, 'Tie::IxHash',
'username' => { label => 'Reseller user name at OpenSRS',
},
'privatekey' => { label => 'Private key',
},
'password' => { label => 'Password for management account',
},
'masterdomain' => { label => 'Master domain at OpenSRS',
},
'wait_for_pay' => { label => 'Do not provision until payment is received',
type => 'checkbox',
default => '0',
},
'debug_level' => { label => 'Net::OpenSRS debug level',
type => 'select',
options => [ 0, 1, 2, 3 ],
default => 0 },
# 'register' => { label => 'Use for registration',
# type => 'checkbox',
# default => '1' },
# 'transfer' => { label => 'Use for transfer',
# 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' },
'auoptions' => { label => 'Enable AU-specific registration fields',
type => 'checkbox'
},
;
%info = (
'svc' => 'svc_domain',
'desc' => 'Domain registration via Tucows OpenSRS',
'options' => \%options,
'notes' => <<'END'
Registers and transfers domains via the Tucows OpenSRS registrar (using Net::OpenSRS).
All of the Net::OpenSRS restrictions apply:
- You must have a reseller account with Tucows.
- You must add the public IP address of the Freeside server to the 'Script API allow' list in the OpenSRS web interface.
- You must generate an API access key in the OpenSRS web interface and enter it below.
- All domains are managed using the same user name and password, but you can create sub-accounts for clients.
- The user name must be the same as your OpenSRS reseller ID.
- You must enter a master domain that all other domains are associated with. That domain must be registered through your OpenSRS account.
Some top-level domains offered by OpenSRS have additional business rules not supported by this export. These TLDs cannot be registered or transfered with this export.
Use these buttons for some useful presets:
END
);
install_callback FS::UID sub {
$conf = new FS::Conf;
};
=head1 METHODS
=over 4
=item format_tel
Reformats a phone number according to registry rules. Currently Freeside stores phone numbers
in NANPA format and the registry prefers "+CCC.NPANPXNNNN"
=cut
sub format_tel {
my $tel = shift;
#if ($tel =~ /^(\d{3})-(\d{3})-(\d{4})( x(\d+))?$/) {
if ($tel =~ /^(\d{3})-(\d{3})-(\d{4})$/) {
$tel = "+1.$1$2$3";
# if $tel .= "$4" if $4;
}
return $tel;
}
=item gen_contact_info
Generates contact data for the domain based on the customer data.
Currently relies on Net::OpenSRS to format the telephone number for OpenSRS.
=cut
sub gen_contact_info
{
my ($co)=@_;
my @invoicing_list = $co->invoicing_list_emailonly;
if ( $conf->exists('emailinvoiceautoalways')
|| $conf->exists('emailinvoiceauto') && ! @invoicing_list
|| ( $conf->exists('emailinvoiceonly') && ! @invoicing_list ) ) {
push @invoicing_list, $co->all_emails;
}
my $email = ($conf->exists('business-onlinepayment-email-override'))
? $conf->config('business-onlinepayment-email-override')
: $invoicing_list[0];
my $c = {
firstname => $co->first,
lastname => $co->last,
company => $co->company,
address => $co->address1,
city => $co->city(),
state => $co->state(),
zip => $co->zip(),
country => uc($co->country()),
email => $email,
#phone => format_tel($co->daytime()),
phone => $co->daytime() || $co->night,
};
return $c;
}
=item validate_contact_info
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_info {
my $c = shift;
my %fields = (
firstname => "first name",
lastname => "last name",
address => "street address",
city => "city",
state => "state",
zip => "ZIP/postal code",
country => "country",
email => "email address",
phone => "phone number",
);
my @err = ();
foreach (keys %fields) {
if (!defined($c->{$_}) || !$c->{$_}) {
push @err, $fields{$_};
}
}
if (scalar(@err) > 0) {
return "Contact information needs: " . join(', ', @err);
}
undef;
}
=item testmode
Returns the Net::OpenSRS-required test mode string based on whether the export
is configured to use the live or the test gateway.
=cut
sub testmode {
my $self = shift;
return 'live' if $self->machine eq "rr-n1-tor.opensrs.net";
return 'test' if $self->machine eq "horizon.opensrs.net";
undef;
}
=item _export_insert
Attempts to "export" the domain, i.e. register or transfer it if the user selected
that option when editing the domain.
Returns an error message on failure or undef on success.
May also return an error message if it cannot load the required Perl module Net::OpenSRS,
or if the domain is not registerable, or if insufficient data is provided in the customer
record to generate the required contact information to register or transfer the domain.
=cut
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;
}
sub _export_insert_on_payment {
my( $self, $svc_domain ) = ( shift, shift );
warn "$me:_export_insert_on_payment called\n" if $DEBUG;
return '' unless $self->option('wait_for_pay');
my $queue = new FS::queue {
'svcnum' => $svc_domain->svcnum,
'job' => 'FS::part_export::domreg_opensrs::renew_through',
};
$queue->insert( $self, $svc_domain ); #_export_insert with 'R' action?
}
## Domain registration exports do nothing on replace. Mainly because we haven't decided what they should do.
#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, $svc_domain ) = ( shift, shift );
#
# return '';
#}
=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 && scalar(@bits) != 3);
my $tld = pop @bits;
my $sld = 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 || $_ eq "$sld$tld" } @tlds;
return undef;
}
=item get_srs
=cut
sub get_srs {
my $self = shift;
my $srs = Net::OpenSRS->new();
$srs->debug_level( $self->option('debug_level') ); # Output should be in the Apache error log
$srs->environment( $self->testmode() );
$srs->set_key( $self->option('privatekey') );
$srs->set_manage_auth( $self->option('username'), $self->option('password') );
return $srs;
}
=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 $rslt = {};
eval "use Net::OpenSRS;";
return $@ if $@;
my $srs = $self->get_srs;
if ($srs->is_available( $svc_domain->domain )) {
$rslt->{'unregistered'} = 1;
} else {
$rslt = $srs->check_transfer( $svc_domain->domain );
if (defined($rslt->{'reason'})) {
my $rv = $srs->make_request(
{
action => 'belongs_to_rsp',
object => 'domain',
attributes => {
domain => $svc_domain->domain
}
}
);
if ($rv) {
$self->_set_response;
if ( $rv->{attributes}->{'domain_expdate'} ) {
$rslt->{'expdate'} = $rv->{attributes}->{'domain_expdate'};
}
}
}
}
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 ) = @_;
$years = 1 unless $years; #default to 1 year since we don't seem to pass it
return "Net::OpenSRS does not support period other than 1 year" if $years != 1;
eval "use Net::OpenSRS;";
return $@ if $@;
my $err = $self->is_supported_domain( $svc_domain );
return $err if $err;
my $cust_main = $svc_domain->cust_svc->cust_pkg->cust_main;
my $c = gen_contact_info($cust_main);
if ( $svc_domain->domain =~ /\.au$/ ) {
$c->{'registrant_name'} = $svc_domain->au_registrant_name;
$c->{'eligibility_type'} = $svc_domain->au_eligibility_type;
}
$err = validate_contact_info($c);
return $err if $err;
my $srs = $self->get_srs;
# cookie not required for registration
# my $cookie = $srs->get_cookie( $self->option('masterdomain') );
# if (!$cookie) {
# return "Unable to get cookie at OpenSRS: " . $srs->last_response();
# }
# return "Domain registration not enabled" if !$self->option('register');
return $srs->last_response() if !$srs->register_domain( $svc_domain->domain, $c);
return ''; # Should only get here if register succeeded
}
=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 ) = @_;
eval "use Net::OpenSRS;";
return $@ if $@;
my $err = $self->is_supported_domain( $svc_domain );
return $err if $err;
my $cust_main = $svc_domain->cust_svc->cust_pkg->cust_main;
my $c = gen_contact_info($cust_main);
$err = validate_contact_info($c);
return $err if $err;
my $srs = $self->get_srs;
my $cookie = $srs->get_cookie( $self->option('masterdomain') );
if (!$cookie) {
return "Unable to get cookie at OpenSRS: " . $srs->last_response();
}
# return "Domain transfer not enabled" if !$self->option('transfer');
return $srs->last_response() if !$srs->transfer_domain( $svc_domain->domain, $c);
return ''; # Should only get here if transfer succeeded
}
=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 ) = @_;
eval "use Net::OpenSRS;";
return $@ if $@;
my $err = $self->is_supported_domain( $svc_domain );
return $err if $err;
my $srs = $self->get_srs;
my $cookie = $srs->get_cookie( $self->option('masterdomain') );
if (!$cookie) {
return "Unable to get cookie at OpenSRS: " . $srs->last_response();
}
# return "Domain renewal not enabled" if !$self->option('renew');
return $srs->last_response() if !$srs->renew_domain( $svc_domain->domain, $years );
return ''; # Should only get here if renewal succeeded
}
=item renew_through [ EPOCH_DATE ]
Attempts to renew the domain through the specified date. If no date is
provided it is gleaned from the associated cust_pkg bill date
Like some export functions, dies on failure or returns undef on success.
It is always called from the queue.
=cut
sub renew_through {
my ( $self, $svc_domain, $date ) = @_;
warn "$me: renew_through called\n" if $DEBUG;
eval "use Net::OpenSRS;";
die $@ if $@;
unless ( $date ) {
my $cust_pkg = $svc_domain->cust_svc->cust_pkg;
die "Can't renew: no date specified and domain is not in a package."
unless $cust_pkg;
$date = $cust_pkg->bill;
}
my $err = $self->is_supported_domain( $svc_domain );
die $err if $err;
warn "$me: checking status\n" if $DEBUG;
my $rv = $self->get_status($svc_domain);
die "Domain ". $svc_domain->domain. " is not renewable"
unless $rv->{expdate};
die "Can't parse expiration date for ". $svc_domain->domain
unless $rv->{expdate} =~ /^(\d{4})-(\d{2})-(\d{2}) (\d{2}):(\d{2}):(\d{2})/;
my ($year,$month,$day,$hour,$minute,$second) = ($1,$2,$3,$4,$5,$6);
my $exp = DateTime->new( year => $year,
month => $month,
day => $day,
hour => $hour,
minute => $minute,
second => $second,
time_zone => 'America/New_York',#timezone of opensrs
);
my $bill = DateTime->
from_epoch( 'epoch' => $date,
'time_zone' => DateTime::TimeZone->new( name => 'local' ),
);
my $years = 0;
while ( DateTime->compare( $bill, $exp ) > 0 ) {
$years++;
$exp->add( 'years' => 1 );
die "Can't renew ". $svc_domain->domain. " for more than 10 years."
if $years > 10; #no infinite loop
}
return '' unless $years;
warn "$me: renewing ". $svc_domain->domain. " for $years years\n" if $DEBUG;
my $srs = $self->get_srs;
$rv = $srs->make_request(
{
action => 'renew',
object => 'domain',
attributes => {
domain => $svc_domain->domain,
auto_renew => 0,
handle => 'process',
period => $years,
currentexpirationyear => $year,
}
}
);
die $rv->{response_text} unless $rv->{is_success};
return ''; # Should only get here if renewal succeeded
}
=item revoke
Attempts to revoke the domain registration. Only succeeds if invoked during the OpenSRS
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 ) = @_;
eval "use Net::OpenSRS;";
return $@ if $@;
my $err = $self->is_supported_domain( $svc_domain );
return $err if $err;
my $srs = $self->get_srs;
my $cookie = $srs->get_cookie( $self->option('masterdomain') );
if (!$cookie) {
return "Unable to get cookie at OpenSRS: " . $srs->last_response();
}
# return "Domain registration revocation not enabled" if !$self->option('revoke');
return $srs->last_response() if !$srs->revoke_domain( $svc_domain->domain);
return ''; # Should only get here if transfer succeeded
}
=item registrar
Should return a full-blown object representing OpenSRS, but current just returns a hashref
containing the registrar name.
=cut
sub registrar {
return {
name => 'OpenSRS',
};
}
=back
=head1 SEE ALSO
L, L, L, L,
L, schema.html from the base documentation.
=cut
1;