File Coverage

blib/lib/IO/EPP/RRPProxy.pm

Criterion	Covered	Total	%
statement	12	134	8.9
branch	0	72	0.0
condition	0	31	0.0
subroutine	4	15	26.6
pod	9	10	90.0
total	25	262	9.5

package IO::EPP::RRPProxy;

=encoding utf8

=head1 NAME

IO::EPP::RRPProxy

=head1 SYNOPSIS

    use IO::EPP::RRPProxy;

    # Parameters for IO::Socket::SSL
    my %sock_params = (
        PeerHost        => 'epp.rrpproxy.net',
        PeerPort        => 700,
        Timeout         => 30,
    );

    # Create object, get greeting and call login()
    my $conn = IO::EPP::RRPProxy->new( {
        user => 'login',
        pass => 'xxxxx',
        sock_params => \%sock_params,
        test_mode => 0, # real connect
    } );

    # Check domain
    my ( $answ, $code, $msg ) = $conn->check_domains( { domains => [ 'info.name', 'name.info' ] } );

    # Call logout() and destroy object
    undef $conn;

=head1 DESCRIPTION

Work with RRPProxy EPP API

Features:

=over 3

item *

has its own epp extension  for specifying additional parameters;

=item *

has additional functions.

=back

Examples: L, L.

=cut

use IO::EPP::Base;
use parent qw( IO::EPP::Base );

use strict;
use warnings;

sub make_request {
    my ( $action, $params ) = @_;

    my ( $self, $code, $msg, $answ );

    unless ( $params->{conn} ) {
        $params->{sock_params}{PeerHost} ||= 'epp.rrpproxy.net';
        $params->{sock_params}{PeerPort} ||= 700;

        ( $self, $code, $msg ) = __PACKAGE__->new( $params );

        unless ( $code  and  $code == 1000 ) {
            goto END_MR;
        }
    }
    else {
        $self = $params->{conn};
    }


    $self->{critical_error} = '';

    if ( $self->can( $action ) ) {
        ( $answ, $code, $msg ) = $self->$action( $params );
    }
    else {
        $msg = "undefined command <$action>, request cancelled";
        $code = 0;
    }


END_MR:

    $msg .= '; ' . $self->{critical_error} if $self->{critical_error};

    my $full_answ = "code: $code\nmsg: $msg";

    $answ = {} unless $answ && ref $answ;

    $answ->{code} = $code;
    $answ->{msg}  = $msg;

    return wantarray ? ( $answ, $full_answ, $self ) : $answ;
}

=head1 METHODS

Further overlap functions where the provider has features

=head2 login

Ext params for login,

INPUT: new password for change

=cut

sub login {
    my ( $self, $pw ) = @_;

    my $svcs = '
    urn:ietf:params:xml:ns:contact-1.0
    urn:ietf:params:xml:ns:domain-1.0
    urn:ietf:params:xml:ns:host-1.0';

    my $extension = '
     http://www.key-systems.net/epp/keysys-1.0
     http://www.key-systems.net/epp/query-1.0
     urn:ietf:params:xml:ns:secDNS-1.1
     urn:ietf:params:xml:ns:rgp-1.0
     urn:ietf:params:xml:ns:launchphase-1.0
     urn:ietf:params:xml:ns:launch-1.0
     urn:ietf:params:xml:ns:idn-1.0
     urn:ietf:params:xml:ns:fee-0.7';

    return $self->SUPER::login( $pw, $svcs, $extension );
}

=head2 create_contact

=cut

sub create_contact {
    my ( $self, $params ) = @_;

    $params->{id} = 'AUTO';

    $params->{company} =~ s/&/&/g  if $params->{company};
    $params->{addr}    =~ s/&/&/g  if $params->{addr};

=pod

    For german characters changes html codes to double symbols:
    ß = ss
    ä = ae
    ü = ue
    ö = oe

=cut
    foreach my $f ( 'name', 'company', 'addr', 'city', 'state' ) {
        next unless $params->{$f};

        $params->{$f} =~ s/Ä/Ae/g;
        $params->{$f} =~ s/Ö/Oe/g;
        $params->{$f} =~ s/Ü/Ue/g;
        $params->{$f} =~ s/ß/ss/g;
        $params->{$f} =~ s/ä/ae/g;
        $params->{$f} =~ s/ö/oe/g;
        $params->{$f} =~ s/ü/ue/g;
    }

    # the extension fields must be arranged in alphabetical order

    my $fields = "\n     1\n";

    # each contact is registered separately even if they are the same
    $params->{extension} =
'
    '.$fields.'


';

    return $self->SUPER::create_contact( $params );
}


=head2 check_claims

Get info on Claims Notice

For details see L

INPUT:

key of params:
C -- domain name

=cut

sub check_claims {
    my ( $self, $params ) = @_;

    $params->{domains} = [ $params->{dname} ];

    $params->{extension} =
'
    claims

';

    return $self->SUPER::check_domains( $params );
}

# Compile trade, premium  and tlds extension
sub _keysys_domain_ext {
    my ( $params ) = @_;

    foreach my $f ( keys %$params ) {
        if ( $f =~ /^x-/ ) {
            $params->{ uc($f) } = delete $params->{$f};
        }
    }

    unless ( $params->{tld} ) {
        ( $params->{tld} ) = $params->{dname} =~ /\.([0-9A-Za-z\-]+)$/;
    }

    my $tld = uc $params->{tld};

    my %ext;

    # for epp need lc
    foreach my $f ( keys %$params ) {
        if ( $f =~ /^X-$tld-$/  or  $f eq 'X-ACCEPT-PREMIUMPRICE'  or  $f eq 'X-ACCEPT-TRADE' ) {
            $ext{ lc($f) } = delete $params->{$f};
        }
    }

    my $extension = '';
    # the extension fields must be arranged in alphabetical order
    foreach my $f ( sort keys %ext ) {
        my $f1 = $f;
        $f1 =~ s/^x-//;
        $extension .= "     $ext{$f}\n";
    }

    return $extension;
}

=head2 create_domain

additional keys of params:

C -- register a premium domain without specifying the price, but it must be allowed in the panel;

C, C -- price for premium domain;

C -- currency for price for premium domain;

C -- subhash for claims parameters:
C, C, C.
For details see L;

The other parameters are zone-specific and are set as specified in The RRPProxy documentation: C.

=cut

sub create_domain {
    my ( $self, $params ) = @_;

    $params->{authinfo} = ''; # need empty

    # Set as RRPProxy documentation, but not epp extension documentation
    $params->{'X-ACCEPT-PREMIUMPRICE'} = 1 if delete $params->{is_premium}; # https://wiki.rrpproxy.net/domains/premium-domains
    $params->{'X-FEE-AMOUNT'}   = delete $params->{premium_price}    if defined $params->{premium_price}; # zero is correct price
    $params->{'X-FEE-AMOUNT'}   = delete $params->{'fee-fee'}        if defined $params->{'fee-fee'};
    $params->{'X-FEE-CURRENCY'} = delete $params->{premium_currency} if $params->{premium_currency};

    my $extension = _keysys_domain_ext( $params );

    # closing special domain extensions
    if ( $extension ) {
        $extension =
'
    '.$extension.'


';
    }


    if ( defined $params->{'X-FEE-AMOUNT'} ) { # https://wiki.rrpproxy.net/domains/premium-domains/x-fee-parameters
        # price can be zero
        $extension .= qq|   \n|;

        if ( $params->{'X-FEE-CURRENCY'} ) {
            $extension .= '    ' . $params->{'X-FEE-CURRENCY'} . "\n";
        }

        $extension .= '    ' . $params->{'X-FEE-AMOUNT'} . "\n   \n";
    }


    if ( $params->{claims} ) {
        $extension .=
'
    claims

     '.    $params->{claims}{noticeID}    .'
     '.    $params->{claims}{notAfter}    .'
     '.$params->{claims}{acceptedDate}.'


';
    }

    $params->{extension} = $extension if $extension;

    return $self->SUPER::create_domain( $params );
}


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

    if ( defined $params->{authinfo} ) {
        $params->{authinfo} =~ s/&/&/g;
        $params->{authinfo} =~ s/
        $params->{authinfo} =~ s/>/>/g;
    }

    my $extension = '';

    if ( $params->{is_premium}  ||  $params->{'X-ACCEPT-PREMIUMPRICE'}  ||  $params->{'x-accept-premiumprice'} ) {
        $extension .= "     1\n";
    }

    if ( $params->{reg_id} ||  $params->{admin_id} ) {
        $extension .= "     $$params{reg_id}\n"         if $params->{reg_id};
        $extension .= "     $$params{admin_id}\n"       if $params->{admin_id};
        $extension .= "     $$params{tech_id}\n"          if $params->{tech_id};
        $extension .= "     $$params{billing_id}\n" if $params->{billing_id};
    }

    if ( $extension ) {
        $params->{extension} =
'

'.$extension.'

';
    }

    return $self->SUPER::transfer( $params );
}

=head2 renew_domain

For renewal of the premium domain name, you need to pass a parameter C or C

=cut

sub renew_domain {
    my ( $self, $params ) = @_;

    if ( $params->{is_premium}  ||  $params->{'X-ACCEPT-PREMIUMPRICE'}  ||  $params->{'x-accept-premiumprice'} ) {
        # https://wiki.rrpproxy.net/domains/premium-domains
        $params->{extension} =
'

     1


';
    }

    return $self->SUPER::renew_domain( $params );
}


=head2 update_domain

C -- option for special change of domain owner -- paid or requires confirmation;

=cut

sub update_domain {
    my ( $self, $params ) = @_;

    $params->{'X-ACCEPT-TRADE'} = 1 if delete $params->{trade};

    my $extension = _keysys_domain_ext( $params );

    if ( $extension ) {
         $params->{extension} =
'
    ' . $extension . '


';
    }

    return $self->SUPER::update_domain( $params );
}


=head2 update_renewalmode

Set renewal mode for domain.

key of params:

C -- variants: C | C | C | C | C | ...

For details see L

=cut

sub update_renewalmode {
    my ( $self, $params ) = @_;

    $params->{extension} =
'

     ' . uc( $params->{renewalmode} ) . '


';

    return $self->update_domain( $params );
}


sub req_poll_ext {
    my ( undef, $ext ) = @_;

    my %info;

    if ( $ext =~ /]+>(.+?)<\/keysys:poll>/s ) {
        my $key_ext = $1;

        foreach my $type ( 'data', 'info' ) {
            if ( $key_ext =~ /(.+?)<\/keysys:$type>/s ) {
                my $data = $1;

                my @data = $data =~ /<[^<>]+>[^<>]+<\/[^<>]+>/g;

                if ( scalar @data ) {
                    foreach my $row ( @data ) {
                        if ( $row =~ /<([^<>]+)>([^<>]+)<\/[^<>]+>/ ) {
                            $info{$1} = $2;
                        }
                    }
                }
                else {
                    $info{$type} = $data;
                }
            }
        }
    }

    return \%info;
}


1;

__END__