From e1f38e426ef49ca5de20680e2baa2ec7f29ac3ce Mon Sep 17 00:00:00 2001 From: pc-stein Date: Tue, 18 Jan 2022 17:18:54 +0000 Subject: [PATCH 01/12] first draft --- lib/Net/DRI/DRD/NameAction.pm | 186 +++++ lib/Net/DRI/Protocol/NameAction.pm | 92 +++ lib/Net/DRI/Protocol/NameAction/Connection.pm | 106 +++ lib/Net/DRI/Protocol/NameAction/Domain.pm | 611 ++++++++++++++++ lib/Net/DRI/Protocol/NameAction/Message.pm | 258 +++++++ t/Net/DRI/Protocol/NameAction.t | 680 ++++++++++++++++++ 6 files changed, 1933 insertions(+) create mode 100644 lib/Net/DRI/DRD/NameAction.pm create mode 100644 lib/Net/DRI/Protocol/NameAction.pm create mode 100644 lib/Net/DRI/Protocol/NameAction/Connection.pm create mode 100644 lib/Net/DRI/Protocol/NameAction/Domain.pm create mode 100644 lib/Net/DRI/Protocol/NameAction/Message.pm create mode 100755 t/Net/DRI/Protocol/NameAction.t diff --git a/lib/Net/DRI/DRD/NameAction.pm b/lib/Net/DRI/DRD/NameAction.pm new file mode 100644 index 00000000..55e3cde0 --- /dev/null +++ b/lib/Net/DRI/DRD/NameAction.pm @@ -0,0 +1,186 @@ +## Domain Registry Interface, OpenSRS Registry Driver +## +## Copyright (c) 2008-2014 Patrick Mevzek . All rights reserved. +## +## This file is part of Net::DRI +## +## Net::DRI is free software; you can redistribute it and/or modify +## it under the terms of the GNU General Public License as published by +## the Free Software Foundation; either version 2 of the License, or +## (at your option) any later version. +## +## See the LICENSE file that comes with this distribution for more details. +#################################################################################################### + +package Net::DRI::DRD::NameAction; + +use strict; +use warnings; + +use base qw/Net::DRI::DRD/; + +use DateTime::Duration; +use Net::DRI::Util; + +=pod + +=head1 NAME + +Net::DRI::DRD::OpenSRS - OpenSRS Registry driver for Net::DRI + +=head1 DESCRIPTION + +Please see the README file for details. + +=head2 CURRENT LIMITATIONS + +Only domain_info and account_list_domains are available. + +=head1 SUPPORT + +For now, support questions should be sent to: + +Enetdri@dotandco.comE + +Please also see the SUPPORT file in the distribution. + +=head1 SEE ALSO + +Ehttp://www.dotandco.com/services/software/Net-DRI/E + +=head1 AUTHOR + +Patrick Mevzek, Enetdri@dotandco.comE + +=head1 COPYRIGHT + +Copyright (c) 2008-2014 Patrick Mevzek . +All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +See the LICENSE file that comes with this distribution for more details. + +=cut + +#################################################################################################### + +sub new +{ + my $class=shift; + my $self=$class->SUPER::new(@_); + return $self; +} + +sub periods { return map { DateTime::Duration->new(years => $_) } (1..10); } +sub name { return 'NameAction'; } +## See http://opensrs.com/site/services/domains/pricing +sub tlds { return (qw/cl/, + ); } +sub object_types { return ('domain'); } +sub profile_types { return qw/nameaction/; } + +sub transport_protocol_default +{ + my ($self,$type)=@_; + + return ('Net::DRI::Transport::HTTP',{},'Net::DRI::Protocol::NameAction',{}) if $type eq 'nameaction'; + return; +} + +#################################################################################################### + +sub domain_operation_needs_is_mine +{ + my ($self,$ndr,$domain,$op)=@_; + return; +} + +sub account_list_domains +{ + my ($self,$ndr)=@_; + my $rc=$ndr->try_restore_from_cache('account','domains','list'); + if (! defined $rc) { $rc=$ndr->process('account','list_domains'); } + return $rc; +} + +sub domain_info +{ + my ($self,$ndr,$domain,$rd)=@_; + $self->enforce_domain_name_constraints($ndr,$domain,'info'); + + my $rc=$ndr->try_restore_from_cache('domain',$domain,'info'); + if (! defined $rc) + { + ## First grab a cookie, if needed + unless (Net::DRI::Util::has_key($rd,'cookie')) + { + $rd=Net::DRI::Util::create_params('domain_info',$rd); ## will fail in set_cookie because other params needed, but at least this will be ok for next line ; otherwise do true checks of value needed + $rd->{domain}=$domain; + $rc=$ndr->process('session','set_cookie',[$rd]); + return $rc unless $rc->is_success(); + $rd->{cookie}=$ndr->get_info('value','session','cookie'); ## Store cookie somewhere (taking into account date of expiry or some TTLs) ? + } + ## Now do the real info + $rc=$ndr->process('domain','info',[$domain,$rd]); ## the $domain is not really used here, as it was used during set_cookie above + } + return $rc; +} + +sub domain_update +{ + my ($self,$ndr,$domain,$changes,$rd)=@_; + $self->enforce_domain_name_constraints($ndr,$domain,'update'); + + ## First grab a cookie, if needed + unless (Net::DRI::Util::has_key($rd,'cookie')) + { + $rd=Net::DRI::Util::create_params('domain_update',$rd); ## will fail in set_cookie because other params needed, but at least this will be ok for next line ; otherwise do true checks of value needed + $rd->{domain}=$domain; + my $rc=$ndr->process('session','set_cookie',[$rd]); + return $rc unless $rc->is_success(); + $rd->{cookie}=$ndr->get_info('value','session','cookie'); ## Store cookie somewhere (taking into account date of expiry or some TTLs) ? + } + ## Now do the real update + my $rc=$ndr->process('domain','update',[$domain,$changes,$rd]); ## the $domain is not really used here, as it was used during set_cookie above + return $rc; +} + +sub domain_is_mine +{ + my ($self,$ndr,$domain,$rd)=@_; + my $clid=$self->info('client_id'); + return unless defined $clid; + my $rc=$ndr->process('domain','is_mine',[$domain,$rd]); + return unless $rc->is_success(); + my $mine=$ndr->get_info('mine'); + return unless defined $mine; + return $mine; +} + +sub domain_send_authcode +{ + my ($self,$ndr,$domain)=@_; + my $rc=$ndr->process('domain','send_authcode',[$domain]); + return $rc; +} + +sub host_registry_check +{ + my ($self,$ndr,$hostname,$registry)=@_; + + return $ndr->process('nameserver', 'registry_check', [$hostname, $registry]); +} + +sub host_registry_add +{ + my ($self,$ndr,$hostname,$rd)=@_; + + return $ndr->process('nameserver', 'registry_add', [$hostname, $rd]); +} + +#################################################################################################### +1; diff --git a/lib/Net/DRI/Protocol/NameAction.pm b/lib/Net/DRI/Protocol/NameAction.pm new file mode 100644 index 00000000..2da7e10a --- /dev/null +++ b/lib/Net/DRI/Protocol/NameAction.pm @@ -0,0 +1,92 @@ +## Domain Registry Interface, OpenSRS XCP Protocol +## +## Copyright (c) 2008-2010,2012,2013 Patrick Mevzek . All rights reserved. +## +## This file is part of Net::DRI +## +## Net::DRI is free software; you can redistribute it and/or modify +## it under the terms of the GNU General Public License as published by +## the Free Software Foundation; either version 2 of the License, or +## (at your option) any later version. +## +## See the LICENSE file that comes with this distribution for more details. +#################################################################################################### + +package Net::DRI::Protocol::NameAction;; + +use strict; +use warnings; + +use base qw(Net::DRI::Protocol); + +use Net::DRI::Protocol::NameAction::Message; + +=pod + +=head1 NAME + +Net::DRI::Protocol::OpenSRS::XCP - OpenSRS XCP Protocol for Net::DRI + +=head1 DESCRIPTION + +Please see the README file for details. + +=head1 SUPPORT + +For now, support questions should be sent to: + +Enetdri@dotandco.comE + +Please also see the SUPPORT file in the distribution. + +=head1 SEE ALSO + +Ehttp://www.dotandco.com/services/software/Net-DRI/E + +=head1 AUTHOR + +Patrick Mevzek, Enetdri@dotandco.comE + +=head1 COPYRIGHT + +Copyright (c) 2008-2010,2012,2013 Patrick Mevzek . +All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +See the LICENSE file that comes with this distribution for more details. + +=cut + +#################################################################################################### + +sub new +{ + my ($c,$ctx,$rp)=@_; + my $drd=$ctx->{registry}->driver(); + my $self=$c->SUPER::new($ctx); + $self->name('nameaction'); + $self->version('1.0.4'); ## Specification March 17, 2008 + $self->factories('message',sub { my $m=Net::DRI::Protocol::NameAction::Message->new(); return $m; }); + $self->_load($rp); + return $self; +} + +sub _load +{ + my ($self,$rp)=@_; + my @class=map { 'Net::DRI::Protocol::NameAction::'.$_ } (qw/Domain/); + return $self->SUPER::_load(@class); +} + +sub transport_default +{ + my ($self)=@_; + return (protocol_connection => 'Net::DRI::Protocol::NameAction::Connection', protocol_version => '1.0'); +} + +#################################################################################################### +1; diff --git a/lib/Net/DRI/Protocol/NameAction/Connection.pm b/lib/Net/DRI/Protocol/NameAction/Connection.pm new file mode 100644 index 00000000..354bf0c0 --- /dev/null +++ b/lib/Net/DRI/Protocol/NameAction/Connection.pm @@ -0,0 +1,106 @@ +## Domain Registry Interface, OpenSRS XCP Connection handling +## +## Copyright (c) 2008-2010,2013 Patrick Mevzek . All rights reserved. +## +## This file is part of Net::DRI +## +## Net::DRI is free software; you can redistribute it and/or modify +## it under the terms of the GNU General Public License as published by +## the Free Software Foundation; either version 2 of the License, or +## (at your option) any later version. +## +## See the LICENSE file that comes with this distribution for more details. +#################################################################################################### + +package Net::DRI::Protocol::NameAction::Connection; + +use strict; +use warnings; + +use Digest::MD5 (); +use HTTP::Request (); + +use Net::DRI::Util; +use Net::DRI::Exception; +use Net::DRI::Data::Raw; +use Net::DRI::Protocol::ResultStatus; + +=pod + +=head1 NAME + +Net::DRI::Protocol::OpenSRS::XCP::Connection - OpenSRS XCP Connection handling for Net::DRI + +=head1 DESCRIPTION + +Please see the README file for details. + +=head1 SUPPORT + +For now, support questions should be sent to: + +Enetdri@dotandco.comE + +Please also see the SUPPORT file in the distribution. + +=head1 SEE ALSO + +Ehttp://www.dotandco.com/services/software/Net-DRI/E + +=head1 AUTHOR + +Patrick Mevzek, Enetdri@dotandco.comE + +=head1 COPYRIGHT + +Copyright (c) 2008-2010,2013 Patrick Mevzek . +All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +See the LICENSE file that comes with this distribution for more details. + +=cut + +#################################################################################################### + +sub init +{ + my ($class,$to)=@_; + my $t=$to->transport_data(); + + foreach my $p (qw/client_login client_password remote_url/) + { + Net::DRI::Exception::usererr_insufficient_parameters($p.' must be defined') unless (exists($t->{$p}) && $t->{$p}); + } + return; +} + +## From Protocol Message object to something suitable for transport (various types) +sub write_message +{ + my ($class,$to,$msg)=@_; + my $t=$to->transport_data(); + my $req=HTTP::Request->new('POST',$t->{remote_url}); +# $req->header('Content-Type','text/xml'); +# $req->header('X-Username',$t->{client_login}); +# my $body=Net::DRI::Util::encode_utf8($msg->get_body()); +# $req->header('X-Signature',Digest::MD5::md5_hex(Digest::MD5::md5_hex($body,$t->{client_password}),$t->{client_password})); ## client_password is in fact the reseller key + $req->content(''); + ## Content-Length will be automatically computed during Transport by LWP::UserAgent + return $req; +} + +## From transport (various types) to Net::DRI::Data::Raw object (which will be parsed inside Protocol::reaction) +sub read_data +{ + my ($class,$to,$res)=@_; + die(Net::DRI::Protocol::ResultStatus->new_error('COMMAND_FAILED_CLOSING',sprintf('Got unsuccessfull HTTP response: %d %s',$res->code(),$res->message()),'en')) unless $res->is_success(); + return Net::DRI::Data::Raw->new_from_xmlstring($res->decoded_content()); +} + +#################################################################################################### +1; diff --git a/lib/Net/DRI/Protocol/NameAction/Domain.pm b/lib/Net/DRI/Protocol/NameAction/Domain.pm new file mode 100644 index 00000000..5d789d63 --- /dev/null +++ b/lib/Net/DRI/Protocol/NameAction/Domain.pm @@ -0,0 +1,611 @@ +## Domain Registry Interface, OpenSRS XCP Domain commands +## +## Copyright (c) 2008-2011 Patrick Mevzek . All rights reserved. +## (c) 2012-2013 Dmitry Belyavsky . All rights reserved. +## +## This file is part of Net::DRI +## +## Net::DRI is free software; you can redistribute it and/or modify +## it under the terms of the GNU General Public License as published by +## the Free Software Foundation; either version 2 of the License, or +## (at your option) any later version. +## +## See the LICENSE file that comes with this distribution for more details. +#################################################################################################### + +package Net::DRI::Protocol::NameAction::Domain; + +use strict; +use warnings; + +use Net::DRI::Exception; +use Net::DRI::Util; + +=pod + +=head1 NAME + +Net::DRI::Protocol::OpenSRS::XCP::Domain - OpenSRS XCP Domain commands for Net::DRI + +=head1 DESCRIPTION + +Please see the README file for details. + +=head1 SUPPORT + +For now, support questions should be sent to: + +Enetdri@dotandco.comE + +Please also see the SUPPORT file in the distribution. + +=head1 SEE ALSO + +Ehttp://www.dotandco.com/services/software/Net-DRI/E + +=head1 AUTHOR + +Patrick Mevzek, Enetdri@dotandco.comE + +=head1 COPYRIGHT + +Copyright (c) 2008-2011 Patrick Mevzek . + (c) 2012-2013 Dmitry Belyavsky . +All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +See the LICENSE file that comes with this distribution for more details. + +=cut + +#################################################################################################### + +sub register_commands +{ + my ($class,$version)=@_; + my %tmp=( + check => [\&check, \&check_parse ], + create => [ \&create, \&create_parse ], + renew => [ \&renew, \&renew_parse ], + transfer_request => [ \&transfer_request, \&transfer_request_parse ], + update => [\&update, undef], #Modify + delete => [ \&delete, \&delete_parse ], + info => [\&info, \&info_parse ], + ); + + return { 'domain' => \%tmp }; +} + +sub build_msg_cookie +{ + my ($msg,$action,$cookie,$regip)=@_; + my %r=(action=>$action,object=>'domain',cookie=>$cookie); + $r{registrant_ip}=$regip if defined($regip); + $msg->command(\%r); + return; +} + +sub info +{ + my ($xcp,$domain,$rd)=@_; + my $msg=$xcp->message(); + Net::DRI::Exception::usererr_insufficient_parameters('A cookie is needed for domain_info') unless Net::DRI::Util::has_key($rd,'cookie'); + build_msg_cookie($msg,'get',$rd->{cookie},$rd->{registrant_ip}); + my $info_type=exists $rd->{type} ? $rd->{type} : 'all_info'; + $msg->command_attributes({type => $info_type}); + return; +} + +sub info_parse +{ + my ($xcp,$otype,$oaction,$oname,$rinfo)=@_; + my $mes=$xcp->message(); + return unless $mes->is_success(); + + $rinfo->{domain}->{$oname}->{action}='info'; + $rinfo->{domain}->{$oname}->{exist}=1; + my $ra=$mes->response_attributes(); ## Not parsed: dns_errors, descr + + my %d=(registry_createdate => 'crDate', registry_expiredate => 'exDate', registry_updatedate => 'upDate', registry_transferdate => 'trDate', expiredate => 'exDateLocal'); + while (my ($k,$v)=each(%d)) + { + next unless exists($ra->{$k}); + $ra->{$k}=~s/\s+/T/; ## with a little effort we become ISO8601 + $rinfo->{domain}->{$oname}->{$v}=$xcp->parse_iso8601($ra->{$k}); + } + + my $ns=$ra->{nameserver_list}; + if (defined($ns) && ref($ns) && @$ns) + { + my $nso=$xcp->create_local_object('hosts'); + foreach my $h (@$ns) + { + $nso->add($h->{name},[$h->{ipaddress}]); + } + $rinfo->{domain}->{$oname}->{ns}=$nso; + } + + foreach my $bool (qw/sponsoring_rsp auto_renew let_expire/) + { + next unless exists($ra->{$bool}); + $rinfo->{domain}->{$oname}->{$bool}=$ra->{$bool}; + } + + my $c=$ra->{contact_set}; + if (defined($c) && ref($c) && keys(%$c)) + { + my $cs=$xcp->create_local_object('contactset'); + while (my ($type,$v)=each(%$c)) + { + my $c=parse_contact($xcp,$v); + $cs->add($c,$type eq 'owner'? 'registrant' : $type); + } + $rinfo->{domain}->{$oname}->{contact}=$cs; + } + + # Status data is available for the separate request + foreach my $opensrs_status (qw/parkp_status lock_state can_modify domain_supports transfer_away_in_progress auctionescrow/) + { + next unless exists $ra->{$opensrs_status}; + $rinfo->{domain}->{$oname}->{$opensrs_status}=$ra->{$opensrs_status}; + } + return; +} + +sub parse_contact +{ + my ($xcp,$rh)=@_; + my $c=$xcp->create_local_object('contact'); + ## No ID given back ! Waouh that is great... not ! + $c->firstname($rh->{first_name}); + $c->name($rh->{last_name}); + $c->org($rh->{org_name}) if exists($rh->{org_name}); + $c->street([map { $rh->{'address'.$_} } grep {exists($rh->{'address'.$_}) && defined($rh->{'address'.$_}) } (1,2,3)]); + $c->city($rh->{city}) if exists($rh->{city}); + $c->sp($rh->{state}) if exists($rh->{state}); + $c->pc($rh->{postal_code}) if exists($rh->{postal_code}); + $c->cc($rh->{country}) if exists($rh->{country}); + $c->voice($rh->{phone}) if exists($rh->{voice}); + $c->fax($rh->{fax}) if exists($rh->{fax}); + $c->email($rh->{email}) if exists($rh->{email}); + $c->url($rh->{url}) if exists($rh->{url}); + return $c; +} + +sub check +{ + my ($nma,$domain,$rd)=@_; + my $msg=$nma->message(); + $msg->command(); + #$msg->command_attributes({domain => $domain}); + return; +} + +sub check_parse +{ + my ($xcp,$otype,$oaction,$oname,$rinfo)=@_; + my $mes=$xcp->message(); + return unless $mes->is_success(); + + $rinfo->{domain}->{$oname}->{action}='check'; + my $ra=$mes->response_attributes(); + $rinfo->{domain}->{$oname}->{exist}=(exists $ra->{status} && defined($ra->{status}) && $ra->{status} eq 'available' && $mes->response_code()==210)? 0 : 1; + $rinfo->{domain}->{$oname}->{exist_reason}=$mes->response_text(); + return; +} + +sub create +{ + my ($xcp,$domain,$rd)=@_; + + sw_register($xcp, $domain, $rd, 'new'); # TBD: premium, sunrise, whois_privacy + return; +} + +sub create_parse +{ + my ($xcp,$otype,$oaction,$oname,$rinfo)=@_; + my $mes=$xcp->message(); + return unless $mes->is_success(); + + $rinfo->{domain}->{$oname}->{action}='create'; + my $ra=$mes->response_attributes(); + foreach (qw/admin_email cancelled_orders error id queue_request_id forced_pending whois_privacy/) { + $rinfo->{domain}->{$oname}->{$_} = $ra->{$_} if exists $ra->{$_}; + } + return; +} + +sub sw_register +{ + my ($xcp,$domain,$rd,$reg_type)=@_; + + my $msg=$xcp->message(); + + my %r=(action => 'sw_register', object => 'domain'); + $r{registrant_ip}=$rd->{registrant_ip} if exists $rd->{registrant_ip}; + + $msg->command(\%r); + + Net::DRI::Exception::usererr_insufficient_parameters('Username+Password are required for sw_register') if grep { ! Net::DRI::Util::has_key($rd,$_) } qw/username password/; + + Net::DRI::Exception::usererr_insufficient_parameters('contacts are mandatory') unless Net::DRI::Util::has_contact($rd); + my $cs=$rd->{contact}; + foreach my $t (qw/registrant admin billing/) + { + my @t=$cs->get($t); + Net::DRI::Exception::usererr_invalid_parameters('one ' . $t . ' contact is mandatory') unless @t==1; + my $co=$cs->get($t); + Net::DRI::Exception::usererr_insufficient_parameters($t . 'contact is mandatory') unless Net::DRI::Util::isa_contact($co); + $co->validate(); + } + + my %contact_set = (); + my $attr = {reg_type => $reg_type, domain => $domain, contact_set => \%contact_set}; + $contact_set{owner} = add_owner_contact($msg,$cs); + $contact_set{admin} = add_admin_contact($msg,$cs); + $contact_set{billing} = add_billing_contact($msg,$cs); + if ($cs->get('tech')) { + $contact_set{tech} = add_tech_contact($msg,$cs); ## optional + $attr->{custom_tech_contact} = 1; + } else { + $attr->{custom_tech_contact} = 0; # Use default tech contact + } + + # These are all the OpenSRS names for optional parameters. Might need to map generic names to OpenSRS namespace later. + foreach (qw/auto_renew affiliate_id f_lock_domain f_parkp f_whois_privacy/) { + $attr->{$_} = ($rd->{$_} ? 1 : 0 ) if Net::DRI::Util::has_key($rd, $_); + } + foreach (qw/affiliate_id reg_domain encoding_type tld_data/) { + $attr->{$_} = ($rd->{$_}) if Net::DRI::Util::has_key($rd, $_); + } + + if (Net::DRI::Util::has_key($rd, 'f_bypass_confirm') && Net::DRI::Util::has_auth($rd)) { + $attr->{'f_bypass_confirm'} = 1; + $attr->{'auth_info'} = $rd->{'auth'}->{'pw'}; + } + + # TBD: ccTLD-specific flags including domain encoding. + # TBD: handle, link_domains, etc. + + if ($reg_type eq 'new') { + Net::DRI::Exception::usererr_insufficient_parameters('duration is mandatory') unless Net::DRI::Util::has_duration($rd); + $attr->{period} = $rd->{duration}->years(); + } + + $attr->{reg_username} = $rd->{username}; + $attr->{reg_password} = $rd->{password}; + + $msg->command_attributes($attr); + + add_all_ns($domain,$msg,$rd->{ns}); + return; +} + +sub update +{ + my ($xcp,$domain,$todo,$rd)=@_; + + my $msg=$xcp->message(); + my $attr = { domain => $domain }; + $msg->command_attributes($attr); + + Net::DRI::Exception::usererr_invalid_parameters($todo.' must be a non empty Net::DRI::Data::Changes object') unless Net::DRI::Util::isa_changes($todo); + Net::DRI::Exception::usererr_insufficient_parameters('A cookie is needed for domain_info') unless Net::DRI::Util::has_key($rd,'cookie'); + + my $nsset=$todo->set('ns'); + my $contactset=$todo->set('contact'); + + if (defined $nsset) + { + Net::DRI::Exception::usererr_invalid_parameters('ns changes for set must be a Net::DRI::Data::Hosts object') unless Net::DRI::Util::isa_hosts($nsset); + Net::DRI::Exception::usererr_invalid_parameters('change of nameservers and contacts is not supported in the same operation') if defined $contactset; + Net::DRI::Exception::usererr_insufficient_parameters('at least 2 nameservers are mandatory') unless ($nsset->count()>=2); + + build_msg_cookie($msg,'advanced_update_nameservers',$rd->{cookie},$rd->{registrant_ip}); + $attr->{op_type}='assign'; + $attr->{assign_ns}=[ $nsset->get_names() ]; + } + else + { + Net::DRI::Exception::usererr_invalid_parameters('contact changes for set must be a Net::DRI::Data::ContactSet') unless defined($contactset) && Net::DRI::Util::isa_contactset($contactset); + + build_msg_cookie($msg,'update_contacts',$rd->{cookie},$rd->{registrant_ip}); + my %contact_set = (); + my $types = []; + foreach my $t (qw/registrant admin billing tech/) + { + my @t=$contactset->get($t); + next unless @t==1; + my $co=$t[0]; + next unless Net::DRI::Util::isa_contact($co); + $co->validate(); + my $registry_type = $t eq 'registrant' ? 'owner' : $t; + $contact_set{$registry_type}=add_contact_info($msg,$co); + push @$types, $registry_type; + } + $attr->{contact_set} = \%contact_set; + $attr->{types} = $types; + } + return; +} + +sub add_contact_info +{ + my ($msg,$co)=@_; + my %contact = (); + + $contact{first_name} = $co->firstname(); + $contact{last_name} = $co->name(); + + $contact{org_name} = $co->org() if $co->org(); + + my $s=$co->street(); + Net::DRI::Exception::usererr_insufficient_parameters('1 line of address at least needed') unless ($s && (ref($s) eq 'ARRAY') && @$s && $s->[0]); + + $contact{address1} = $s->[0]; + $contact{address2} = $s->[1] if $s->[1]; + $contact{address3} = $s->[2] if $s->[2]; + Net::DRI::Exception::usererr_insufficient_parameters('city & cc mandatory') unless ($co->city() && $co->cc()); + $contact{city} = $co->city(); + #TODO state and postal_code are required for US/CA + $contact{state} = $co->sp() if $co->sp(); + $contact{postal_code} = $co->pc() if $co->pc(); + $contact{country} = uc($co->cc()); + Net::DRI::Exception::usererr_insufficient_parameters('voice & email mandatory') unless ($co->voice() && $co->email()); + $contact{phone} = $co->voice(); + $contact{fax} = $co->fax() if $co->fax(); + $contact{email} = $co->email(); + $contact{url} = $co->url() if $co->url(); + return \%contact; +} + +sub add_owner_contact +{ + my ($msg,$cs)=@_; + my $co=$cs->get('registrant'); + return add_contact_info($msg,$co) if Net::DRI::Util::isa_contact($co); + return; +} + +sub add_admin_contact +{ + my ($msg,$cs)=@_; + my $co=$cs->get('admin'); + return add_contact_info($msg,$co) if Net::DRI::Util::isa_contact($co); + return; +} + +sub add_billing_contact +{ + my ($msg,$cs)=@_; + my $co=$cs->get('billing'); + return add_contact_info($msg,$co) if Net::DRI::Util::isa_contact($co); + return; +} + +sub add_tech_contact +{ + my ($msg,$cs)=@_; + my $co=$cs->get('tech'); + return add_contact_info($msg,$co) if Net::DRI::Util::isa_contact($co); + return; +} + +sub add_all_ns +{ + my ($domain,$msg,$ns)=@_; + my @nslist = (); + + my $attr = $msg->command_attributes(); + $attr->{custom_nameservers} = 0; + + if (defined($ns)) { + Net::DRI::Exception::usererr_insufficient_parameters('at least 2 nameservers are mandatory') unless (Net::DRI::Util::isa_hosts($ns) && $ns->count()>=2); # Name servers are optional; if present must be >=2 + + for (my $i = 1; $i <= $ns->count(); $i++) { # Net:DRI name server list starts at 1. + my $name = $ns->get_details($i); # get_details in scalar returns name + push @nslist, { sortorder => $i, name => $name }; + } + $attr->{custom_nameservers} = 1; + $attr->{nameserver_list} = \@nslist; + } + $msg->command_attributes($attr); + return; +} + +sub delete ## no critic (Subroutines::ProhibitBuiltinHomonyms) +{ + my ($xcp,$domain,$rd)=@_; + my $msg=$xcp->message(); + + Net::DRI::Exception::usererr_insufficient_parameters('Reseller ID is mandatory') unless (Net::DRI::Util::has_key($rd, 'reseller_id')); + + my %r=(action => 'revoke', object => 'domain'); + $r{registrant_ip}=$rd->{registrant_ip} if exists $rd->{registrant_ip}; + + $msg->command(\%r); + my $attr = {domain => $domain, reseller => $rd->{reseller_id}}; + $attr->{notes} = $rd->{notes} if Net::DRI::Util::has_key($rd, 'notes'); + $msg->command_attributes({domain => $domain, reseller => $rd->{reseller_id}}); + return; +} + +sub delete_parse +{ + my ($xcp,$otype,$oaction,$oname,$rinfo)=@_; + my $mes=$xcp->message(); + return unless $mes->is_success(); + + $rinfo->{domain}->{$oname}->{action}='delete'; + my $ra=$mes->response_attributes(); + foreach (qw/charge price/) { + $rinfo->{domain}->{$oname}->{$_} = $ra->{$_} if exists $ra->{$_}; + } + return; +} + +sub renew +{ + my ($xcp,$domain,$rd)=@_; + my $msg=$xcp->message(); + + my %r=(action => 'renew', object => 'domain'); + $r{registrant_ip}=$rd->{registrant_ip} if exists $rd->{registrant_ip}; + + Net::DRI::Exception::usererr_insufficient_parameters('auto_renew setting is mandatory') unless (Net::DRI::Util::has_key($rd, 'auto_renew')); + + Net::DRI::Exception::usererr_insufficient_parameters('duration is mandatory') unless Net::DRI::Util::has_duration($rd); + Net::DRI::Exception::usererr_insufficient_parameters('current expiration is mandatory') unless (Net::DRI::Util::has_key($rd, 'current_expiration') && Net::DRI::Util::check_isa($rd->{current_expiration}, 'DateTime')); # Can get this from set_cookie response. + + my $attr = {domain => $domain, period => $rd->{duration}->years(), currentexpirationyear => $rd->{current_expiration}->year()}; + + # These are all the OpenSRS names for optional parameters. Might need to map generic names to OpenSRS namespace later. + foreach (qw/auto_renew f_parkp/) { + $attr->{$_} = ($rd->{$_} ? 1 : 0 ) if Net::DRI::Util::has_key($rd, $_); + } + foreach (qw/affiliate_id notes/) { + $attr->{$_} = ($rd->{$_}) if Net::DRI::Util::has_key($rd, $_); + } + + $rd->{handle} ||= 'process'; + $attr->{handle} = $rd->{handle}; + # TBD: handle, etc. + + $msg->command(\%r); + $msg->command_attributes($attr); + return; +} + +sub renew_parse +{ + my ($xcp,$otype,$oaction,$oname,$rinfo)=@_; + my $mes=$xcp->message(); + return unless $mes->is_success(); + + $rinfo->{domain}->{$oname}->{action}='renew'; + my $ra=$mes->response_attributes(); + foreach (qw/auto_renew admin_email order_id id queue_request_id/) { + $rinfo->{domain}->{$oname}->{$_} = $ra->{$_} if exists $ra->{$_}; + } + my ($k,$v)=('registration expiration date', 'exDate'); + $ra->{$k}=~s/\s+/T/; ## with a little effort we become ISO8601 + $rinfo->{domain}->{$oname}->{$v}=$xcp->parse_iso8601($ra->{$k}) if defined($ra->{$k}); + return; +} + +sub transfer_request +{ + my ($xcp,$domain,$rd)=@_; + + sw_register($xcp, $domain, $rd, 'transfer'); + return; +} + +sub transfer_request_parse +{ + my ($xcp,$otype,$oaction,$oname,$rinfo)=@_; + my $mes=$xcp->message(); + return unless $mes->is_success(); + + $rinfo->{domain}->{$oname}->{action}='transfer_start'; + my $ra=$mes->response_attributes(); + foreach (qw/admin_email cancelled_orders error id queue_request_id forced_pending whois_privacy/) { + $rinfo->{domain}->{$oname}->{$_} = $ra->{$_} if exists $ra->{$_}; + } + return; +} + +sub transfer_query +{ + my ($xcp,$domain,$rd)=@_; + my $msg=$xcp->message(); + + my %r=(action => 'check_transfer', object => 'domain'); + $r{registrant_ip}=$rd->{registrant_ip} if exists $rd->{registrant_ip}; + + $msg->command(\%r); + $msg->command_attributes({domain => $domain, check_status => 1, get_request_address => 1}); # TBD: usable for checking transferability + return; +} + +sub transfer_query_parse +{ + my ($xcp,$otype,$oaction,$oname,$rinfo)=@_; + my $mes=$xcp->message(); + return unless $mes->is_success(); + + $rinfo->{domain}->{$oname}->{action}='check_transfer'; + my $ra=$mes->response_attributes(); + foreach (qw/transferrable status request_address timestamp unixtime reason type noservice/) { + $rinfo->{domain}->{$oname}->{$_} = $ra->{$_} if exists $ra->{$_}; + } + return; +} + +sub transfer_cancel +{ + my ($xcp,$domain,$rd)=@_; + my $msg=$xcp->message(); + + Net::DRI::Exception::usererr_insufficient_parameters('Reseller ID is mandatory') unless (Net::DRI::Util::has_key($rd, 'reseller_id')); + + my %r=(action => 'cancel_transfer', object => 'transfer'); + $r{registrant_ip}=$rd->{registrant_ip} if exists $rd->{registrant_ip}; + + $msg->command(\%r); + $msg->command_attributes({domain => $domain, reseller => $rd->{reseller_id}}); # TBD: optional order ID + return; +} + +sub transfer_cancel_parse +{ + my ($xcp,$otype,$oaction,$oname,$rinfo)=@_; + my $mes=$xcp->message(); + return unless $mes->is_success(); + + $rinfo->{domain}->{$oname}->{action}='cancel_transfer'; + # This response has no attributes to capture + return; +} + +sub is_mine +{ + my ($xcp,$domain,$rd)=@_; + my $msg=$xcp->message(); + + # Cookie isn't used with belongs_to_rsp + + $msg->command ({ action => 'belongs_to_rsp' }); + $msg->command_attributes ({ domain => $domain }); + return; +} + +sub is_mine_parse +{ + my ($xcp,$otype,$oaction,$oname,$rinfo)=@_; + my $mes=$xcp->message(); + return unless $mes->is_success(); + + $rinfo->{domain}->{$oname}->{action} = 'is_mine'; + $rinfo->{domain}->{$oname}->{exist} = 1; + + my $ra=$mes->response_attributes(); + return unless exists $ra->{belongs_to_rsp} && defined $ra->{belongs_to_rsp}; + + $rinfo->{domain}->{$oname}->{mine}=($ra->{belongs_to_rsp})? 1 : 0; + if (exists $ra->{domain_expdate} && defined $ra->{domain_expdate}) ## only here if belongs_to_rsp=1 + { + my $d=$ra->{domain_expdate}; + $d=~s/\s+/T/; ## with a little effort we become ISO8601 + $rinfo->{domain}->{$oname}->{exDate}=$xcp->parse_iso8601($d); + } + return; +} + +#################################################################################################### +1; diff --git a/lib/Net/DRI/Protocol/NameAction/Message.pm b/lib/Net/DRI/Protocol/NameAction/Message.pm new file mode 100644 index 00000000..bfb45146 --- /dev/null +++ b/lib/Net/DRI/Protocol/NameAction/Message.pm @@ -0,0 +1,258 @@ +## Domain Registry Interface, OpenSRS XCP Message +## +## Copyright (c) 2008-2010,2012-2014 Patrick Mevzek . All rights reserved. +## +## This file is part of Net::DRI +## +## Net::DRI is free software; you can redistribute it and/or modify +## it under the terms of the GNU General Public License as published by +## the Free Software Foundation; either version 2 of the License, or +## (at your option) any later version. +## +## See the LICENSE file that comes with this distribution for more details. +#################################################################################################### + +package Net::DRI::Protocol::NameAction::Message; + +use strict; +use warnings; + +use XML::LibXML (); + +use Net::DRI::Protocol::ResultStatus; +use Net::DRI::Exception; +use Net::DRI::Util; + +use base qw(Class::Accessor::Chained::Fast Net::DRI::Protocol::Message); +__PACKAGE__->mk_accessors(qw(version client_auth command command_attributes response_attributes response_code response_text response_is_success)); + +=pod + +=head1 NAME + +Net::DRI::Protocol::OpenSRS::XCP::Message - OpenSRS XCP Message for Net::DRI + +=head1 DESCRIPTION + +Please see the README file for details. + +=head1 SUPPORT + +For now, support questions should be sent to: + +Enetdri@dotandco.comE + +Please also see the SUPPORT file in the distribution. + +=head1 SEE ALSO + +Ehttp://www.dotandco.com/services/software/Net-DRI/E + +=head1 AUTHOR + +Patrick Mevzek, Enetdri@dotandco.comE + +=head1 COPYRIGHT + +Copyright (c) 2008-2010,2012-2014 Patrick Mevzek . +All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +See the LICENSE file that comes with this distribution for more details. + +=cut + +#################################################################################################### + +sub new +{ + my ($class,$trid)=@_; + my $self={ results => [], command => {}}; + bless($self,$class); + + $self->version('0.9'); + return $self; +} + +our %CODES=( 200 => 1000, + 210 => 2303, + 211 => 2302, + 212 => 1000, + 221 => 2302, + 250 => 1001, + 300 => 1001, + 310 => 2502, + 350 => 2502, ## A maximum of 100 commands can be sent through one connection/session. After 100 commands have been submitted, the connection is closed and a new connection must be opened to submit outstanding requests. + 400 => 2400, + 404 => 2400, + 405 => 2400, + 410 => 2200, + 415 => 2200, + 430 => 2000, + 435 => 2201, + 436 => 2400, + 437 => 2304, + 440 => 2201, + 445 => 2201, + 447 => 2201, + 460 => 2003, + 465 => 2005, + 480 => 2306, + 485 => 2302, + 486 => 2304, + 487 => 2106, + 541 => 2004, + 552 => 2304, + 555 => 2306, + 557 => 2305, + 705 => 2400, + ); + +sub result_status +{ + my $self=shift; + return Net::DRI::Protocol::ResultStatus->new_success($self->response_text()) if $self->response_is_success(); + my $code=$self->response_code(); + my $eppcode=(defined $code && exists $CODES{$code})? $CODES{$code} : 'COMMAND_FAILED'; + return Net::DRI::Protocol::ResultStatus->new('opensrs_xcp',$code,$eppcode,$self->response_is_success(),$self->response_text(),'en'); +} + +sub is_success { return shift->response_is_success(); } +sub as_string { + my $self=shift; + my $cmd=$self->command(); +} + +sub _obj2dt +{ + my ($in)=@_; + my @r; + foreach my $el ($in) + { + my $ref=ref($el); + if (!$ref) + { + push @r,sprintf('%s',Net::DRI::Util::xml_escape($el)); + } elsif ($ref eq 'HASH') + { + my @c; + foreach my $k (sort { $a cmp $b } keys %$el) + { + $k=~s/"/"/g; + my $v=$el->{$k}; + if (!defined($v)) { + push @c,sprintf('',$k); + } else { + push @c,sprintf('%s',$k,ref($v)? _obj2dt($v) : Net::DRI::Util::xml_escape($v)); + } + } + push @r,sprintf('%s',join('',@c)); + } elsif ($ref eq 'ARRAY') + { + my @c; + foreach my $i (0..$#$el) + { + push @c,sprintf('%s',$i,ref($el->[$i])? _obj2dt($el->[$i]) : Net::DRI::Util::xml_escape($el->[$i])); + } + push @r,sprintf('%s',join('',@c)); + } elsif ($ref eq 'SCALAR') + { + push @r,sprintf('%s',Net::DRI::Util::xml_escape($$el)); ## defined in specifications, but not really used ? + } else + { + Net::DRI::Exception::err_assert('_obj2dt cannot deal with data '.$el); + } + } + return @r; +} + +sub _dt2obj ## no critic (Subroutines::RequireFinalReturn) +{ + my ($doc)=@_; + my $c=$doc->getFirstChild(); + return unless defined($c); + while (defined($c) && $c->nodeType()!=1) { $c=$c->getNextSibling(); } + return $doc->textContent() unless (defined($c) && $c->nodeType()==1); + my $n=$c->nodeName(); + if ($n eq 'dt_scalar') + { + return $c->textContent(); + } elsif ($n eq 'dt_assoc') + { + my %r; + foreach my $item ($c->getChildrenByTagName('item')) + { + $r{$item->getAttribute('key')}=_dt2obj($item); + } + return \%r; + } elsif ($n eq 'dt_array') + { + my @r; + foreach my $item ($c->getChildrenByTagName('item')) + { + $r[$item->getAttribute('key')]=_dt2obj($item); + } + return \@r; + } + + Net::DRI::Exception::err_assert('_dt2obj ca not deal with node name '.$n); +} + +sub parse +{ + my ($self,$dr,$rinfo,$otype,$oaction,$msgsent)=@_; + use Data::Dumper; + print Dumper(@_); + $self->command($msgsent->command()); ## Copy over for reference from message sent + + my $parser=XML::LibXML->new(); + my $doc=$parser->parse_string($dr->as_string()); + my $root=$doc->getDocumentElement(); + Net::DRI::Exception->die(0,'protocol/NameAction',1,'Unsuccessful parse, root element is not "nck" but '.$root->getName()) unless ($root->getName() eq 'nck'); + + my $resp=$root->getElementsByTagName('response'); + Net::DRI::Exception->die(0,'protocol/NameAction',1,'Unsuccessful parse, expected only one "response" node below root, found '.$resp->size()) unless ($resp->size()==1); + + my @nodes = $resp->get_node(1)->getChildrenByTagName('command'); + Net::DRI::Exception->die(0,'protocol/NameAction',1,'Unsuccessful parse, expected only one "command" node below responset, found '.scalar(@nodes)) unless (scalar(@nodes)==1); + + @nodes = $resp->get_node(1)->getChildrenByTagName('value'); + Net::DRI::Exception->die(0,'protocol/NameAction',1,'Unsuccessful parse, expected only one "command" node below responset, found '.scalar(@nodes)) unless (scalar(@nodes)==1); + + my $msg =$root->getElementsByTagName('message'); + Net::DRI::Exception->die(0,'protocol/NameAction',1,'Unsuccessful parse, expected only one "message" node below root, found '.$resp->size()) unless ($resp->size()==1); + + $self->response_text($msg->get_node()->textContent()); +# { +# my $key=$item->getAttribute('key'); +# next if ($key eq 'protocol' || $key eq 'action' || $key eq 'object'); ## protocol is XCP, action is always REPLY, and we already have object in command() +# if ($key eq 'attributes') ## specific data about requested action, should always be an hash based on documentation +# { +# $self->response_attributes(_dt2obj($item)); +# next; +# } +# if ($key eq 'response_code') ## meaning is action-specific +# { +# $self->response_code($item->textContent()); +# next; +# } +# if ($key eq 'response_text') ## meaning is action-specific +# { +# +# next; +# } +# if ($key eq 'is_success') ## 0 if not successful, 1 if action was successful +# { +# $self->response_is_success($item->textContent()); +# next; +# } +# } + return; +} + +#################################################################################################### +1; diff --git a/t/Net/DRI/Protocol/NameAction.t b/t/Net/DRI/Protocol/NameAction.t new file mode 100755 index 00000000..033f097e --- /dev/null +++ b/t/Net/DRI/Protocol/NameAction.t @@ -0,0 +1,680 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Net::DRI; +use Net::DRI::Data::Raw; +use DateTime::Duration; +use DateTime; +use Test::More tests => 45; +eval { no warnings; require Test::LongString; Test::LongString->import(max => 100); $Test::LongString::Context=50; }; +if ( $@ ) { no strict 'refs'; *{'main::is_string'}=\&main::is; } + + +our ($R1,$R2); +our (@R1,@R2); #FIXME + +sub mysend { my ($transport,$count,$msg)=@_; $R1 = $msg->as_string(); return 1;} +sub myrecv { return Net::DRI::Data::Raw->new_from_string($R2); } +sub munge { my $in=shift; $in=~s/>\s*new({cache_ttl => 10}); +$dri->add_registry('NameAction'); +$dri->target('NameAction')->add_current_profile('p1','nameaction',{f_send=>\&mysend,f_recv=>\&myrecv,client_login=>'LOGIN',client_password=>'PASSWORD',remote_url=>'http://localhost/'}); + +my ($r,$rc,$rd,$ns,$cs); + + +$R2 = <<'EOF'; + + + check + 1 + + + Domain nameaction.cl is available + + +EOF + +$r=<<'EOF'; +EOF +$rc=$dri->domain_check('nameaction.cl'); +is($R1,'https://ncktest.nameaction.com/interface?User=ncktest&Pass=ncktest&Command=Check&SLD=nameaction&TLD=cl','domain_check build'); +is($rc->is_success(),1,'domain_check is_success'); +is($dri->get_info('action'),'check','domain_check get_info(action)'); +is($dri->get_info('exist'),0,'domain_check get_info(exist)'); +is($dri->get_info('exist','domain','example3.com'),0,'domain_check get_info(exist) from cache'); + + +exit 1; + +#===Contact sets to test registration=================================== + +my $admin_co=<<'EOF'; + + 32 Catmas Street + Suite 100 + Admin + SomeCity + US + admin@example.com + +1.4165550125 + Adler + Admin + Catmas Inc. + +1.4165550123x1812 + 90210 + CA + http://www.catmas.com + +EOF + +my $defcs=<<"EOF"; + + + + $admin_co + + + + Bill + Billing + +1.4165550123x1248 + +1.4165550136 + billing\@example.com + Catmas Inc. + 32 Catmas Street + Suite 200 + Billing + SomeCity + CA + US + 90210 + http://www.catmas.com + + + + + Owen + Owner + +1.4165550123x1902 + +1.4165550124 + owner\@example.com + Catmas Inc. + 32 Catmas Street + Suite 500 + Owner + SomeCity + CA + US + 90210 + http://www.catmas.com + + + + + Tim + Tech + +1.4165550123x1243 + +1.4165550125 + techie\@example.com + Catmas Inc. + 32 Catmas Street + Suite 100 + Tech + SomeCity + CA + US + 90210 + http://www.catmas.com + + + + +EOF + +#===Test registration with default name servers=================================== + +push @R2,<<'EOF'; + + + create + 1000 + + Request to Create the domain nameaction.cl was successfully received for 2 year(s). (Cost USD$95.0) + + +EOF + +$cs=$dri->local_object('contactset'); +my $co=$dri->local_object('contact'); +$co->srid('daniel'); # Portfolio user name for OpenSRS? +$co->auth('daniel'); # Portfolio password for OpenSRS? +$co->name('Admin'); # Should be firstname, name => lastname. +$co->firstname('Adler'); +$co->org('Catmas Inc.'); +$co->street(['32 Catmas Street','Suite 100','Admin']); +$co->city('SomeCity'); +$co->sp('CA'); +$co->pc('90210'); +$co->cc('US'); +$co->voice('+1.4165550123x1812'); +$co->fax('+1.4165550125'); +$co->email('admin@example.com'); +$co->url('http://www.catmas.com'); + +$cs->set($co,'registrant'); +$cs->set($co,'admin'); +$cs->set($co,'billing'); + +$r=<<"EOF"; + + + +
+ 0.9 +
+ + + + sw_register + domain + XCP + 10.0.10.19 + + + + + + $admin_co + + + $admin_co + + + $admin_co + + + + 0 + 0 + example-nsi.net + 10 + daniel + new + daniel + + + + + + +EOF + +$rc=$dri->domain_create('example-nsi.net',{username => 'daniel', password => 'daniel', contact => $cs, registrant_ip => '10.0.10.19', pure_create => 1, duration => DateTime::Duration->new(years =>10)}); +is_string(munge(shift(@R1)),munge($r),'domain_create (default name servers)'); +is($rc->is_success(),1,'domain_create is_success (default name servers)'); +#is($rc->native_code(),200,'domain_create native_code (default name servers)'); +is($rc->code(),1000,'domain_create code (default name servers)'); +is($dri->get_info('id'),3735281,'domain_create id'); +#is($dri->get_info_keys(),'admin_email','domain_create response keys'); +#is($dri->get_info('registration_code'),200,'domain_create get_info(registration_code)'); +#is($dri->get_info('domain','example-nsi.net','admin_email'),'jsmith@catmas.com','domain_create get_info(admin_email)'); +is($dri->get_info('admin_email'),'jsmith@catmas.com','domain_create get_info(admin_email)'); + +#===Test registration with default name servers=================================== + +push @R2,<<'EOF'; + + + +
+ 0.9 +
+ + + + XCP + REPLY + DOMAIN + 0 + 435 + + Request failed validation: Name server + 'dns1.example.com' is not found at the registry. Please double check + the nameserver and re-submit. + Name server 'dns2.example.com' is not found at the + registry. Please double check the nameserver and re-submit. + + + + + Request failed validation: Name server + 'dns1.example.com' is not found at the registry. Please double check + the nameserver and re-submit. + Name server 'dns2.example.com' is not found at the + registry. Please double check the nameserver and re-submit. + + 435 + 3735283 + 3735283 + + + + + + +EOF + +$r=<<"EOF"; + + + +
+ 0.9 +
+ + + + sw_register + domain + XCP + 216.40.46.115 + + + + + + $admin_co + + + $admin_co + + + $admin_co + + + + 1 + 0 + yahoo.com + + + + + ns1.domaindirect.com + 1 + + + + + ns2.domaindirect.com + 2 + + + + + 7 + daniel + new + daniel + + + + + + +EOF + +$ns=$dri->local_object('hosts'); +$ns->add('ns1.domaindirect.com',['123.45.67.89']); +$ns->add('ns2.domaindirect.com'); + +#SKIP: { +# skip 'dt_array bug', 3; +$rc=$dri->domain_create('yahoo.com',{username => 'daniel', password => 'daniel', contact => $cs, registrant_ip => '216.40.46.115', pure_create => 1, duration => DateTime::Duration->new(years =>7), ns => $ns}); +is_string(munge(shift(@R1)),munge($r),'domain_create (custom name servers)'); +is($rc->is_success(),0,'domain_create is_success (custom name servers)'); +#is($dri->get_info('response_code'),435,'domain_create get_info(response_code)'); +#is($dri->get_info('registration_code'),435,'domain_create get_info(registration_code)'); +#}; + +#===Test renew=================================== + +#pop @R2; + +push @R2,<<'EOF'; + + + +
+0.9 +
+ + + +XCP +REPLY +DOMAIN + + +2006-01-08 15:35:00 +1 +admin1@example.com +3212624 +3511417 + + +Command completed successfully +1 +200 + + + + +EOF + +$r=<<'EOF'; + + + +
+0.9 +
+ + + +renew +domain +XCP +216.40.46.115 + + +1 +2009 +example.com +process +5 + + + + + + +EOF + +$rc=$dri->domain_renew('example.com',{username => 'daniel', password => 'guessthis', registrant_ip => '216.40.46.115', auto_renew => 1, duration => DateTime::Duration->new(years =>5), current_expiration => DateTime->new( year => 2009, month => 06, day => 27)}); +is_string(munge(shift(@R1)),munge($r),'domain_renew'); +is($rc->is_success(),1,'domain_renew is_success'); +is($dri->get_info('admin_email'),'admin1@example.com','domain_renew get_info(admin_email)'); +is(''.$dri->get_info('exDate'),'2006-01-08T15:35:00','domain_info get_info(exDate)'); +#is($dri->get_info('registration expiration date'),'2006-12-07 00:00:00','domain_renew get_info(expiration date)'); + +#===Test revoke=================================== + +push @R2,<<'EOF'; + + + +
+0.9 +
+ + + +XCP +REPLY +DOMAIN +1 + + +0 +undef + + +Domain test.com revoked successfully. +200 + + + + +EOF + +$r=<<"EOF"; + + + +
+0.9 +
+ + + +revoke +domain +XCP +216.40.46.115 + + +example.com +$RESELLERID + + + + + + +EOF + +$rc=$dri->domain_delete('example.com',{pure_delete => 1, username => 'daniel', password => 'guessthis', registrant_ip => '216.40.46.115', reseller_id => $RESELLERID}); +is_string(munge(shift(@R1)),munge($r),'domain_delete'); +is($rc->is_success(),1,'domain_delete is_success'); +is($dri->get_info('charge'),0,'domain_renew get_info(charge)'); + +#===Test transfer initiation=================================== + +push @R2,<<'EOF'; + + + +
+0.9 +
+ + + +XCP +REPLY +DOMAIN +200 +Transfer request has been successfully sent +1 + + +Transfer request has been successfully sent +200 +3735288 + + + + + + +EOF + +$r=<<"EOF"; + + + +
+0.9 +
+ + + +sw_register +domain +XCP +10.0.10.19 + + + + + + $admin_co + + + $admin_co + + + $admin_co + + + +0 +0 +yahoo.com +example +transfer +example + + + + + + +EOF + +$rc=$dri->domain_transfer_start('yahoo.com',{username => 'example', password => 'example', contact => $cs, registrant_ip => '10.0.10.19'}); +is_string(munge(shift(@R1)),munge($r),'domain_transfer_start'); +is($rc->is_success(),1,'domain_transfer_start is_success'); +is($dri->get_info('id'),3735288,'domain_transfer_start get_info(id)'); + +#===Test transfer check=================================== + +push @R2,<<'EOF'; + + + +
+0.9 +
+ + + +XCP +REPLY +DOMAIN +1 +Query successful +200 + + +pending_owner +0 +Transfer in progress + +1115213766 +Wed May 4 09:36:06 2005 + + + + + + +EOF + +$r=<<'EOF'; + + + +
+0.9 +
+ + + +check_transfer +domain +XCP +216.40.46.115 + + +1 +catmas.com +1 + + + + + + +EOF + +$rc=$dri->domain_transfer_query('catmas.com',{username => 'daniel', password => 'guessthis', registrant_ip => '216.40.46.115'}); +is_string(munge(shift(@R1)),munge($r),'domain_transfer_query'); +is($rc->is_success(),1,'domain_transfer_query is_success'); +is($dri->get_info('transferrable'),0,'domain_transfer_query get_info(transferrable)'); +is($dri->get_info('reason'),'Transfer in progress','domain_transfer_query get_info(reason)'); +is($dri->get_info('unixtime'),1115213766,'domain_transfer_query get_info(reason)'); + +#===Test transfer cancel=================================== + +push @R2,<<'EOF'; + + + +
+0.9 +
+ + + +XCP +REPLY +TRANSFER +Transfer with order id: 3533098 has been canceled. +1 +200 + + + + +EOF + +$r=<<"EOF"; + + + +
+0.9 +
+ + + +cancel_transfer +transfer +XCP +216.40.46.115 + + +example.com +$RESELLERID + + + + + + +EOF + +$rc=$dri->domain_transfer_stop('example.com',{username => 'daniel', password => 'guessthis', registrant_ip => '216.40.46.115', reseller_id => $RESELLERID}); +is_string(munge(shift(@R1)),munge($r),'domain_transfer_stop'); +is($rc->is_success(),1,'domain_transfer_stop is_success'); + +exit 0; + From 9850652f94c12422f4c1bbb4be2b743c2258431c Mon Sep 17 00:00:00 2001 From: pc-stein Date: Tue, 25 Jan 2022 12:53:49 +0000 Subject: [PATCH 02/12] Name response parse --- lib/Net/DRI/Protocol/NameAction/Domain.pm | 42 +++--- lib/Net/DRI/Protocol/NameAction/Message.pm | 82 +++--------- t/Net/DRI/Protocol/NameAction.t | 145 ++------------------- 3 files changed, 47 insertions(+), 222 deletions(-) diff --git a/lib/Net/DRI/Protocol/NameAction/Domain.pm b/lib/Net/DRI/Protocol/NameAction/Domain.pm index 5d789d63..c7b93983 100644 --- a/lib/Net/DRI/Protocol/NameAction/Domain.pm +++ b/lib/Net/DRI/Protocol/NameAction/Domain.pm @@ -89,6 +89,28 @@ sub build_msg_cookie return; } +sub check +{ + my ($nma,$domain,$rd)=@_; + my $msg=$nma->message(); + $msg->command(); + return; +} + +sub check_parse +{ + my ($nma,$otype,$oaction,$oname,$rinfo)=@_; + #use Data::Dumper; print Dumper(\@_); + print join ",", @_; + my $mes=$nma->message(); + return unless $mes->is_success(); + + $rinfo->{domain}->{$oname}->{action}='check'; + $rinfo->{domain}->{$oname}->{exist}=$mes->response_code() ? 0 : 1; + $rinfo->{domain}->{$oname}->{exist_reason}=$mes->response_text(); + return; +} + sub info { my ($xcp,$domain,$rd)=@_; @@ -176,27 +198,7 @@ sub parse_contact return $c; } -sub check -{ - my ($nma,$domain,$rd)=@_; - my $msg=$nma->message(); - $msg->command(); - #$msg->command_attributes({domain => $domain}); - return; -} -sub check_parse -{ - my ($xcp,$otype,$oaction,$oname,$rinfo)=@_; - my $mes=$xcp->message(); - return unless $mes->is_success(); - - $rinfo->{domain}->{$oname}->{action}='check'; - my $ra=$mes->response_attributes(); - $rinfo->{domain}->{$oname}->{exist}=(exists $ra->{status} && defined($ra->{status}) && $ra->{status} eq 'available' && $mes->response_code()==210)? 0 : 1; - $rinfo->{domain}->{$oname}->{exist_reason}=$mes->response_text(); - return; -} sub create { diff --git a/lib/Net/DRI/Protocol/NameAction/Message.pm b/lib/Net/DRI/Protocol/NameAction/Message.pm index bfb45146..5cd83e13 100644 --- a/lib/Net/DRI/Protocol/NameAction/Message.pm +++ b/lib/Net/DRI/Protocol/NameAction/Message.pm @@ -24,7 +24,7 @@ use Net::DRI::Exception; use Net::DRI::Util; use base qw(Class::Accessor::Chained::Fast Net::DRI::Protocol::Message); -__PACKAGE__->mk_accessors(qw(version client_auth command command_attributes response_attributes response_code response_text response_is_success)); +__PACKAGE__->mk_accessors(qw(version client_auth command command_attributes response_code response_text response_command response_is_success)); =pod @@ -74,7 +74,7 @@ sub new my $self={ results => [], command => {}}; bless($self,$class); - $self->version('0.9'); + $self->version('1.04'); return $self; } @@ -170,38 +170,6 @@ sub _obj2dt return @r; } -sub _dt2obj ## no critic (Subroutines::RequireFinalReturn) -{ - my ($doc)=@_; - my $c=$doc->getFirstChild(); - return unless defined($c); - while (defined($c) && $c->nodeType()!=1) { $c=$c->getNextSibling(); } - return $doc->textContent() unless (defined($c) && $c->nodeType()==1); - my $n=$c->nodeName(); - if ($n eq 'dt_scalar') - { - return $c->textContent(); - } elsif ($n eq 'dt_assoc') - { - my %r; - foreach my $item ($c->getChildrenByTagName('item')) - { - $r{$item->getAttribute('key')}=_dt2obj($item); - } - return \%r; - } elsif ($n eq 'dt_array') - { - my @r; - foreach my $item ($c->getChildrenByTagName('item')) - { - $r[$item->getAttribute('key')]=_dt2obj($item); - } - return \@r; - } - - Net::DRI::Exception::err_assert('_dt2obj ca not deal with node name '.$n); -} - sub parse { my ($self,$dr,$rinfo,$otype,$oaction,$msgsent)=@_; @@ -211,46 +179,26 @@ sub parse my $parser=XML::LibXML->new(); my $doc=$parser->parse_string($dr->as_string()); + my $root=$doc->getDocumentElement(); Net::DRI::Exception->die(0,'protocol/NameAction',1,'Unsuccessful parse, root element is not "nck" but '.$root->getName()) unless ($root->getName() eq 'nck'); - my $resp=$root->getElementsByTagName('response'); + my $resp = $root->getElementsByTagName('response'); Net::DRI::Exception->die(0,'protocol/NameAction',1,'Unsuccessful parse, expected only one "response" node below root, found '.$resp->size()) unless ($resp->size()==1); - my @nodes = $resp->get_node(1)->getChildrenByTagName('command'); - Net::DRI::Exception->die(0,'protocol/NameAction',1,'Unsuccessful parse, expected only one "command" node below responset, found '.scalar(@nodes)) unless (scalar(@nodes)==1); - - @nodes = $resp->get_node(1)->getChildrenByTagName('value'); - Net::DRI::Exception->die(0,'protocol/NameAction',1,'Unsuccessful parse, expected only one "command" node below responset, found '.scalar(@nodes)) unless (scalar(@nodes)==1); + my $cmd = $resp->get_node(1)->getChildrenByTagName('command'); + Net::DRI::Exception->die(0,'protocol/NameAction',1,'Unsuccessful parse, expected only one "command" node below responset, found '.$cmd->size()) unless ($cmd->size()==1); + $self->response_command($cmd->get_node(0)->textContent()); - my $msg =$root->getElementsByTagName('message'); - Net::DRI::Exception->die(0,'protocol/NameAction',1,'Unsuccessful parse, expected only one "message" node below root, found '.$resp->size()) unless ($resp->size()==1); + my $val = $resp->get_node(1)->getChildrenByTagName('value'); + Net::DRI::Exception->die(0,'protocol/NameAction',1,'Unsuccessful parse, expected only one "value" node below responset, found '.$val->size()) unless ($val->size()==1); + $self->response_code($val->get_node(0)->textContent()); - $self->response_text($msg->get_node()->textContent()); -# { -# my $key=$item->getAttribute('key'); -# next if ($key eq 'protocol' || $key eq 'action' || $key eq 'object'); ## protocol is XCP, action is always REPLY, and we already have object in command() -# if ($key eq 'attributes') ## specific data about requested action, should always be an hash based on documentation -# { -# $self->response_attributes(_dt2obj($item)); -# next; -# } -# if ($key eq 'response_code') ## meaning is action-specific -# { -# $self->response_code($item->textContent()); -# next; -# } -# if ($key eq 'response_text') ## meaning is action-specific -# { -# -# next; -# } -# if ($key eq 'is_success') ## 0 if not successful, 1 if action was successful -# { -# $self->response_is_success($item->textContent()); -# next; -# } -# } + my $msg=$root->getElementsByTagName('message'); + Net::DRI::Exception->die(0,'protocol/NameAction',1,'Unsuccessful parse, expected only one "message" node below root, found '.$msg->size()) unless ($msg->size()==1); + $self->response_text($msg->get_node(0)->textContent()); + + $self->response_is_success(1); return; } diff --git a/t/Net/DRI/Protocol/NameAction.t b/t/Net/DRI/Protocol/NameAction.t index 033f097e..51b9c08c 100755 --- a/t/Net/DRI/Protocol/NameAction.t +++ b/t/Net/DRI/Protocol/NameAction.t @@ -47,96 +47,10 @@ is($R1,'https://ncktest.nameaction.com/interface?User=ncktest&Pass=ncktest&Comma is($rc->is_success(),1,'domain_check is_success'); is($dri->get_info('action'),'check','domain_check get_info(action)'); is($dri->get_info('exist'),0,'domain_check get_info(exist)'); -is($dri->get_info('exist','domain','example3.com'),0,'domain_check get_info(exist) from cache'); - +is($dri->get_info('exist','domain','nameaction.cl'),0,'domain_check get_info(exist) from cache'); exit 1; -#===Contact sets to test registration=================================== - -my $admin_co=<<'EOF'; - - 32 Catmas Street - Suite 100 - Admin - SomeCity - US - admin@example.com - +1.4165550125 - Adler - Admin - Catmas Inc. - +1.4165550123x1812 - 90210 - CA - http://www.catmas.com - -EOF - -my $defcs=<<"EOF"; - - - - $admin_co - - - - Bill - Billing - +1.4165550123x1248 - +1.4165550136 - billing\@example.com - Catmas Inc. - 32 Catmas Street - Suite 200 - Billing - SomeCity - CA - US - 90210 - http://www.catmas.com - - - - - Owen - Owner - +1.4165550123x1902 - +1.4165550124 - owner\@example.com - Catmas Inc. - 32 Catmas Street - Suite 500 - Owner - SomeCity - CA - US - 90210 - http://www.catmas.com - - - - - Tim - Tech - +1.4165550123x1243 - +1.4165550125 - techie\@example.com - Catmas Inc. - 32 Catmas Street - Suite 100 - Tech - SomeCity - CA - US - 90210 - http://www.catmas.com - - - - -EOF - #===Test registration with default name servers=================================== push @R2,<<'EOF'; @@ -155,7 +69,8 @@ my $co=$dri->local_object('contact'); $co->srid('daniel'); # Portfolio user name for OpenSRS? $co->auth('daniel'); # Portfolio password for OpenSRS? $co->name('Admin'); # Should be firstname, name => lastname. -$co->firstname('Adler'); +$co->firstname('John'); +$co->lastname('Doe'); $co->org('Catmas Inc.'); $co->street(['32 Catmas Street','Suite 100','Admin']); $co->city('SomeCity'); @@ -172,47 +87,7 @@ $cs->set($co,'admin'); $cs->set($co,'billing'); $r=<<"EOF"; - - - -
- 0.9 -
- - - - sw_register - domain - XCP - 10.0.10.19 - - - - - - $admin_co - - - $admin_co - - - $admin_co - - - - 0 - 0 - example-nsi.net - 10 - daniel - new - daniel - - - - - - +https://ncktest.nameaction.com/interface?User=ncktest&Pass=ncktest&Command=Create&SLD=nameaction&TLD=cl&Year=1&RegistrantName=JohnDoe&RegistrantOrganization=NameAction DomainLA&RegistrantAddress=1156 HighStreet&RegistrantCity=California&RegistrantCountryCode=US&RegistrantPostalCode=95064&RegistrantPhone=1.1234567&RegistrantEmail=j.doe@nameaction.com&AdminName=John Doe&AdminOrganization=NameAction DomainLA&AdminAddress=1156 HighStreet&AdminCity=California&AdminCountryCode=US&AdminPostalCode=95064&AdminPhone=1.1234567&AdminEmail=j.doe@nameaction.com&TechName=JohnDoe&TechOrganization=NameAction Domain LA&TechAddress=1156 HighStreet&TechCity=California&TechCountryCode=US&TechPostalCode=95064&TechPhone=1.1234567&TechEmail=j.doe@nameaction.com&NS1=ns1.nameaction.com&NS2=ns2.nameaction.com&IP1=200.27.54.210&IP2=200.27.54.211&InfoPL=55555555-5 EOF $rc=$dri->domain_create('example-nsi.net',{username => 'daniel', password => 'daniel', contact => $cs, registrant_ip => '10.0.10.19', pure_create => 1, duration => DateTime::Duration->new(years =>10)}); @@ -289,13 +164,13 @@ $r=<<"EOF"; - $admin_co + admin_co - $admin_co + admin_co - $admin_co + admin_co @@ -525,13 +400,13 @@ $r=<<"EOF"; - $admin_co + admin_co - $admin_co + admin_co - $admin_co + admin_co From 716776e56f509c9717823914000f54776b190a87 Mon Sep 17 00:00:00 2001 From: pc-stein Date: Thu, 27 Jan 2022 10:17:03 +0000 Subject: [PATCH 03/12] build domain commands start --- lib/Net/DRI/Protocol/NameAction/Connection.pm | 9 +++------ lib/Net/DRI/Protocol/NameAction/Domain.pm | 13 ++++++++++--- t/Net/DRI/Protocol/NameAction.t | 2 +- 3 files changed, 14 insertions(+), 10 deletions(-) diff --git a/lib/Net/DRI/Protocol/NameAction/Connection.pm b/lib/Net/DRI/Protocol/NameAction/Connection.pm index 354bf0c0..648b1668 100644 --- a/lib/Net/DRI/Protocol/NameAction/Connection.pm +++ b/lib/Net/DRI/Protocol/NameAction/Connection.pm @@ -84,13 +84,10 @@ sub write_message { my ($class,$to,$msg)=@_; my $t=$to->transport_data(); - my $req=HTTP::Request->new('POST',$t->{remote_url}); -# $req->header('Content-Type','text/xml'); -# $req->header('X-Username',$t->{client_login}); -# my $body=Net::DRI::Util::encode_utf8($msg->get_body()); -# $req->header('X-Signature',Digest::MD5::md5_hex(Digest::MD5::md5_hex($body,$t->{client_password}),$t->{client_password})); ## client_password is in fact the reseller key + my $url = sprintf('%s?%s', $t->{remote_url}, join('&',$t->{client_login},$t->{client_password})); + my $req=HTTP::Request->new('POST',$url); + $req->header('Content-Type','text/xml'); $req->content(''); - ## Content-Length will be automatically computed during Transport by LWP::UserAgent return $req; } diff --git a/lib/Net/DRI/Protocol/NameAction/Domain.pm b/lib/Net/DRI/Protocol/NameAction/Domain.pm index c7b93983..bf0f5cee 100644 --- a/lib/Net/DRI/Protocol/NameAction/Domain.pm +++ b/lib/Net/DRI/Protocol/NameAction/Domain.pm @@ -89,19 +89,26 @@ sub build_msg_cookie return; } +sub _build_command { + my ($mes,$action,$domain,$attrs) = @_; + Net::DRI::Exception->die(1,'NameAction/Domain',2,'Domain name needed') unless $domain; #FIXME handle multiple domains? see epp Util.pm + #Command=Check&SLD=nameaction&TLD=cl' + $cmd = + return $cmd; +} + sub check { my ($nma,$domain,$rd)=@_; my $msg=$nma->message(); - $msg->command(); + my $cmd = _build_command($msg,'check',$domain); + $msg->command($cmd); return; } sub check_parse { my ($nma,$otype,$oaction,$oname,$rinfo)=@_; - #use Data::Dumper; print Dumper(\@_); - print join ",", @_; my $mes=$nma->message(); return unless $mes->is_success(); diff --git a/t/Net/DRI/Protocol/NameAction.t b/t/Net/DRI/Protocol/NameAction.t index 51b9c08c..3b729636 100755 --- a/t/Net/DRI/Protocol/NameAction.t +++ b/t/Net/DRI/Protocol/NameAction.t @@ -87,7 +87,7 @@ $cs->set($co,'admin'); $cs->set($co,'billing'); $r=<<"EOF"; -https://ncktest.nameaction.com/interface?User=ncktest&Pass=ncktest&Command=Create&SLD=nameaction&TLD=cl&Year=1&RegistrantName=JohnDoe&RegistrantOrganization=NameAction DomainLA&RegistrantAddress=1156 HighStreet&RegistrantCity=California&RegistrantCountryCode=US&RegistrantPostalCode=95064&RegistrantPhone=1.1234567&RegistrantEmail=j.doe@nameaction.com&AdminName=John Doe&AdminOrganization=NameAction DomainLA&AdminAddress=1156 HighStreet&AdminCity=California&AdminCountryCode=US&AdminPostalCode=95064&AdminPhone=1.1234567&AdminEmail=j.doe@nameaction.com&TechName=JohnDoe&TechOrganization=NameAction Domain LA&TechAddress=1156 HighStreet&TechCity=California&TechCountryCode=US&TechPostalCode=95064&TechPhone=1.1234567&TechEmail=j.doe@nameaction.com&NS1=ns1.nameaction.com&NS2=ns2.nameaction.com&IP1=200.27.54.210&IP2=200.27.54.211&InfoPL=55555555-5 +https://ncktest.nameaction.com/interface?User=ncktest&Pass=ncktest&Command=Create&SLD=nameaction&TLD=cl&Year=1&RegistrantName=JohnDoe&RegistrantOrganization=NameAction DomainLA&RegistrantAddress=1156 HighStreet&RegistrantCity=California&RegistrantCountryCode=US&RegistrantPostalCode=95064&RegistrantPhone=1.1234567&RegistrantEmail=j.doenameaction.com&AdminName=John Doe&AdminOrganization=NameAction DomainLA&AdminAddress=1156 HighStreet&AdminCity=California&AdminCountryCode=US&AdminPostalCode=95064&AdminPhone=1.1234567&AdminEmail=j.doenameaction.com&TechName=JohnDoe&TechOrganization=NameAction Domain LA&TechAddress=1156 HighStreet&TechCity=California&TechCountryCode=US&TechPostalCode=95064&TechPhone=1.1234567&TechEmail=j.doenameaction.com&NS1=ns1.nameaction.com&NS2=ns2.nameaction.com&IP1=200.27.54.210&IP2=200.27.54.211&InfoPL=55555555-5 EOF $rc=$dri->domain_create('example-nsi.net',{username => 'daniel', password => 'daniel', contact => $cs, registrant_ip => '10.0.10.19', pure_create => 1, duration => DateTime::Duration->new(years =>10)}); From 5be830947c984cc2f6fb694f3d0686ca5059ff6e Mon Sep 17 00:00:00 2001 From: pc-stein Date: Fri, 4 Feb 2022 10:14:29 +0000 Subject: [PATCH 04/12] Create string Url in Connection.pm, correct sent command test --- lib/Net/DRI/Protocol/NameAction/Connection.pm | 18 +++++++++++++++--- lib/Net/DRI/Protocol/NameAction/Domain.pm | 12 +++++++++--- lib/Net/DRI/Protocol/NameAction/Message.pm | 8 +++++--- t/Net/DRI/Protocol/NameAction.t | 11 +++++++++-- 4 files changed, 38 insertions(+), 11 deletions(-) diff --git a/lib/Net/DRI/Protocol/NameAction/Connection.pm b/lib/Net/DRI/Protocol/NameAction/Connection.pm index 648b1668..faabd43f 100644 --- a/lib/Net/DRI/Protocol/NameAction/Connection.pm +++ b/lib/Net/DRI/Protocol/NameAction/Connection.pm @@ -19,6 +19,7 @@ use warnings; use Digest::MD5 (); use HTTP::Request (); +use URI; use Net::DRI::Util; use Net::DRI::Exception; @@ -71,7 +72,6 @@ sub init { my ($class,$to)=@_; my $t=$to->transport_data(); - foreach my $p (qw/client_login client_password remote_url/) { Net::DRI::Exception::usererr_insufficient_parameters($p.' must be defined') unless (exists($t->{$p}) && $t->{$p}); @@ -83,14 +83,26 @@ sub init sub write_message { my ($class,$to,$msg)=@_; - my $t=$to->transport_data(); - my $url = sprintf('%s?%s', $t->{remote_url}, join('&',$t->{client_login},$t->{client_password})); + my $url = build_url(@_); my $req=HTTP::Request->new('POST',$url); $req->header('Content-Type','text/xml'); $req->content(''); return $req; } +sub build_url +{ + my ($class,$to,$msg)=@_; + my $t=$to->transport_data(); + + my $uri = URI->new($t->{remote_url}); + $uri->query_form( User => $t->{client_login}, + Pass => $t->{client_password}, + @{$msg->command()} + ); + return $uri->as_string(); +} + ## From transport (various types) to Net::DRI::Data::Raw object (which will be parsed inside Protocol::reaction) sub read_data { diff --git a/lib/Net/DRI/Protocol/NameAction/Domain.pm b/lib/Net/DRI/Protocol/NameAction/Domain.pm index bf0f5cee..faa95f20 100644 --- a/lib/Net/DRI/Protocol/NameAction/Domain.pm +++ b/lib/Net/DRI/Protocol/NameAction/Domain.pm @@ -20,6 +20,7 @@ use warnings; use Net::DRI::Exception; use Net::DRI::Util; +use URI; =pod @@ -92,9 +93,14 @@ sub build_msg_cookie sub _build_command { my ($mes,$action,$domain,$attrs) = @_; Net::DRI::Exception->die(1,'NameAction/Domain',2,'Domain name needed') unless $domain; #FIXME handle multiple domains? see epp Util.pm - #Command=Check&SLD=nameaction&TLD=cl' - $cmd = - return $cmd; + + my ($sdl, $tld) = ($domain =~ /^([^\.]+)\.(.+)$/); + my @fragments = ( 'Command' => ucfirst($action), #FIXME check if uppercase is really needed + 'SLD' => $sdl, + 'TLD' => $tld + ); + push @fragments, %$attrs if defined $attrs && ref $attrs eq 'HASH'; + return \@fragments } sub check diff --git a/lib/Net/DRI/Protocol/NameAction/Message.pm b/lib/Net/DRI/Protocol/NameAction/Message.pm index 5cd83e13..1b8b2f7b 100644 --- a/lib/Net/DRI/Protocol/NameAction/Message.pm +++ b/lib/Net/DRI/Protocol/NameAction/Message.pm @@ -18,6 +18,7 @@ use strict; use warnings; use XML::LibXML (); +use URI; use Net::DRI::Protocol::ResultStatus; use Net::DRI::Exception; @@ -124,7 +125,9 @@ sub result_status sub is_success { return shift->response_is_success(); } sub as_string { my $self=shift; - my $cmd=$self->command(); + my $uri = URI->new(); + $uri->query_form($self->{command}); + return $uri->query(); } sub _obj2dt @@ -173,8 +176,7 @@ sub _obj2dt sub parse { my ($self,$dr,$rinfo,$otype,$oaction,$msgsent)=@_; - use Data::Dumper; - print Dumper(@_); + #use Data::Dumper; print Dumper(@_); $self->command($msgsent->command()); ## Copy over for reference from message sent my $parser=XML::LibXML->new(); diff --git a/t/Net/DRI/Protocol/NameAction.t b/t/Net/DRI/Protocol/NameAction.t index 3b729636..0a18cc15 100755 --- a/t/Net/DRI/Protocol/NameAction.t +++ b/t/Net/DRI/Protocol/NameAction.t @@ -5,6 +5,7 @@ use warnings; use Net::DRI; use Net::DRI::Data::Raw; +use Net::DRI::Protocol::NameAction::Connection; use DateTime::Duration; use DateTime; use Test::More tests => 45; @@ -15,7 +16,13 @@ if ( $@ ) { no strict 'refs'; *{'main::is_string'}=\&main::is; } our ($R1,$R2); our (@R1,@R2); #FIXME -sub mysend { my ($transport,$count,$msg)=@_; $R1 = $msg->as_string(); return 1;} +sub mysend { my ($transport,$count,$msg,$ctx)=@_; + *{Net::DRI::Transport::Dummy::transport_data} = sub { return {remote_url => 'https://ncktest.nameaction.com/interface', + client_login => 'ncktest', + client_password => 'ncktest'}}; + $R1 = Net::DRI::Protocol::NameAction::Connection->build_url($transport,$msg); + return 1; +} sub myrecv { return Net::DRI::Data::Raw->new_from_string($R2); } sub munge { my $in=shift; $in=~s/>\s*new({cache_ttl => 10}); $dri->add_registry('NameAction'); -$dri->target('NameAction')->add_current_profile('p1','nameaction',{f_send=>\&mysend,f_recv=>\&myrecv,client_login=>'LOGIN',client_password=>'PASSWORD',remote_url=>'http://localhost/'}); +$dri->target('NameAction')->add_current_profile('p1','nameaction',{f_send=>\&mysend,f_recv=>\&myrecv});#,client_login=>'LOGIN',client_password=>'PASSWORD',remote_url=>'http://localhost/'}); my ($r,$rc,$rd,$ns,$cs); From f08182061bf33718119a023cd80c13fb00e23f5c Mon Sep 17 00:00:00 2001 From: pc-stein Date: Mon, 7 Feb 2022 14:36:16 +0000 Subject: [PATCH 05/12] Create request draft --- lib/Net/DRI/Protocol/NameAction/Domain.pm | 20 +++--- t/Net/DRI/Protocol/NameAction.t | 74 +++++++++++++---------- 2 files changed, 51 insertions(+), 43 deletions(-) diff --git a/lib/Net/DRI/Protocol/NameAction/Domain.pm b/lib/Net/DRI/Protocol/NameAction/Domain.pm index faa95f20..918ac67c 100644 --- a/lib/Net/DRI/Protocol/NameAction/Domain.pm +++ b/lib/Net/DRI/Protocol/NameAction/Domain.pm @@ -211,27 +211,25 @@ sub parse_contact return $c; } - - sub create { - my ($xcp,$domain,$rd)=@_; - - sw_register($xcp, $domain, $rd, 'new'); # TBD: premium, sunrise, whois_privacy + my ($nma,$domain,$rd)=@_; + my $msg=$nma->message(); + + my $cmd = _build_command($msg,'create',$domain); + $msg->command($cmd); return; } sub create_parse { - my ($xcp,$otype,$oaction,$oname,$rinfo)=@_; - my $mes=$xcp->message(); + my ($nma,$otype,$oaction,$oname,$rinfo)=@_; + my $mes=$nma->message(); return unless $mes->is_success(); $rinfo->{domain}->{$oname}->{action}='create'; - my $ra=$mes->response_attributes(); - foreach (qw/admin_email cancelled_orders error id queue_request_id forced_pending whois_privacy/) { - $rinfo->{domain}->{$oname}->{$_} = $ra->{$_} if exists $ra->{$_}; - } + $rinfo->{domain}->{$oname}->{exist}=$mes->response_code() ? 0 : 1; + $rinfo->{domain}->{$oname}->{exist_reason}=$mes->response_text(); return; } diff --git a/t/Net/DRI/Protocol/NameAction.t b/t/Net/DRI/Protocol/NameAction.t index 0a18cc15..c66b0400 100755 --- a/t/Net/DRI/Protocol/NameAction.t +++ b/t/Net/DRI/Protocol/NameAction.t @@ -56,10 +56,12 @@ is($dri->get_info('action'),'check','domain_check get_info(action)'); is($dri->get_info('exist'),0,'domain_check get_info(exist)'); is($dri->get_info('exist','domain','nameaction.cl'),0,'domain_check get_info(exist) from cache'); -exit 1; - #===Test registration with default name servers=================================== +$r=<<"EOF"; +https://ncktest.nameaction.com/interface?User=ncktest&Pass=ncktest&Command=Create&SLD=nameaction&TLD=cl&Year=1&RegistrantName=JohnDoe&RegistrantOrganization=NameAction DomainLA&RegistrantAddress=1156 HighStreet&RegistrantCity=California&RegistrantCountryCode=US&RegistrantPostalCode=95064&RegistrantPhone=1.1234567&RegistrantEmail=j.doenameaction.com&AdminName=John Doe&AdminOrganization=NameAction DomainLA&AdminAddress=1156 HighStreet&AdminCity=California&AdminCountryCode=US&AdminPostalCode=95064&AdminPhone=1.1234567&AdminEmail=j.doenameaction.com&TechName=JohnDoe&TechOrganization=NameAction Domain LA&TechAddress=1156 HighStreet&TechCity=California&TechCountryCode=US&TechPostalCode=95064&TechPhone=1.1234567&TechEmail=j.doenameaction.com&NS1=ns1.nameaction.com&NS2=ns2.nameaction.com&IP1=200.27.54.210&IP2=200.27.54.211&InfoPL=55555555-5 +EOF + push @R2,<<'EOF'; @@ -72,41 +74,49 @@ push @R2,<<'EOF'; EOF $cs=$dri->local_object('contactset'); -my $co=$dri->local_object('contact'); -$co->srid('daniel'); # Portfolio user name for OpenSRS? -$co->auth('daniel'); # Portfolio password for OpenSRS? -$co->name('Admin'); # Should be firstname, name => lastname. -$co->firstname('John'); -$co->lastname('Doe'); -$co->org('Catmas Inc.'); -$co->street(['32 Catmas Street','Suite 100','Admin']); -$co->city('SomeCity'); -$co->sp('CA'); -$co->pc('90210'); -$co->cc('US'); -$co->voice('+1.4165550123x1812'); -$co->fax('+1.4165550125'); -$co->email('admin@example.com'); -$co->url('http://www.catmas.com'); - -$cs->set($co,'registrant'); -$cs->set($co,'admin'); -$cs->set($co,'billing'); - -$r=<<"EOF"; -https://ncktest.nameaction.com/interface?User=ncktest&Pass=ncktest&Command=Create&SLD=nameaction&TLD=cl&Year=1&RegistrantName=JohnDoe&RegistrantOrganization=NameAction DomainLA&RegistrantAddress=1156 HighStreet&RegistrantCity=California&RegistrantCountryCode=US&RegistrantPostalCode=95064&RegistrantPhone=1.1234567&RegistrantEmail=j.doenameaction.com&AdminName=John Doe&AdminOrganization=NameAction DomainLA&AdminAddress=1156 HighStreet&AdminCity=California&AdminCountryCode=US&AdminPostalCode=95064&AdminPhone=1.1234567&AdminEmail=j.doenameaction.com&TechName=JohnDoe&TechOrganization=NameAction Domain LA&TechAddress=1156 HighStreet&TechCity=California&TechCountryCode=US&TechPostalCode=95064&TechPhone=1.1234567&TechEmail=j.doenameaction.com&NS1=ns1.nameaction.com&NS2=ns2.nameaction.com&IP1=200.27.54.210&IP2=200.27.54.211&InfoPL=55555555-5 -EOF - -$rc=$dri->domain_create('example-nsi.net',{username => 'daniel', password => 'daniel', contact => $cs, registrant_ip => '10.0.10.19', pure_create => 1, duration => DateTime::Duration->new(years =>10)}); -is_string(munge(shift(@R1)),munge($r),'domain_create (default name servers)'); +my $reg_co=$dri->local_object('contact'); +#$reg_co->srid('daniel'); # Portfolio user name for OpenSRS? +#$reg_co->auth('daniel'); # Portfolio password for OpenSRS? +#$reg_co->name('Admin'); # Should be firstname, name => lastname. +$reg_co->name('John Doe'); +$reg_co->org('NameAction DomainLA'); +$reg_co->street(['1156 HighStreet','','']); +$reg_co->city('California'); +#$reg_co->sp('CA'); +$reg_co->pc('95064'); +$reg_co->cc('US'); +$reg_co->voice('1.1234567'); +#$reg_co->fax('+1.4165550125'); +$reg_co->email('j.doenameaction.com'); +#$reg_co->url('http://www.catmas.com'); + +$cs->set($reg_co,'registrant'); +$cs->set($reg_co,'admin'); +$cs->set($reg_co,'tech'); + +$ns = $dri->local_object('hosts')->set(['ns1.example.com',''],['ns1.example.net']); + +$rc = $dri->domain_create('nameaction.cl',{ pure_create =>1, + duration => DateTime::Duration->new(years=>2), + ns => $ns, + contact => $cs, + auth => {pw=>'2fooBAR'}}); + +is_string($R1,$r,'domain_create build'); is($rc->is_success(),1,'domain_create is_success (default name servers)'); -#is($rc->native_code(),200,'domain_create native_code (default name servers)'); is($rc->code(),1000,'domain_create code (default name servers)'); -is($dri->get_info('id'),3735281,'domain_create id'); +is($dri->get_info('action'),'create','domain_create get_info(action)'); +is($dri->get_info('exist'),1,'domain_create get_info(exist)'); +#is($dri->get_info('id'),3735281,'domain_create id'); +#is($rc->native_code(),200,'domain_create native_code (default name servers)'); #is($dri->get_info_keys(),'admin_email','domain_create response keys'); #is($dri->get_info('registration_code'),200,'domain_create get_info(registration_code)'); #is($dri->get_info('domain','example-nsi.net','admin_email'),'jsmith@catmas.com','domain_create get_info(admin_email)'); -is($dri->get_info('admin_email'),'jsmith@catmas.com','domain_create get_info(admin_email)'); +#is($dri->get_info('admin_email'),'jsmith@catmas.com','domain_create get_info(admin_email)'); + + + +exit 1; #===Test registration with default name servers=================================== From 3ff0e4750cd2d0034b46e5c6da4a82147628e749 Mon Sep 17 00:00:00 2001 From: pc-stein Date: Mon, 14 Mar 2022 10:40:55 +0000 Subject: [PATCH 06/12] NameAction Alpha release --- lib/Net/DRI/DRD/NameAction.pm | 108 +-- lib/Net/DRI/Protocol/NameAction.pm | 20 +- lib/Net/DRI/Protocol/NameAction/Connection.pm | 16 +- lib/Net/DRI/Protocol/NameAction/Domain.pm | 676 ++++++----------- lib/Net/DRI/Protocol/NameAction/Message.pm | 161 ++-- t/Net/DRI/Protocol/NameAction.t | 693 ++++++------------ 6 files changed, 518 insertions(+), 1156 deletions(-) diff --git a/lib/Net/DRI/DRD/NameAction.pm b/lib/Net/DRI/DRD/NameAction.pm index 55e3cde0..e74444e6 100644 --- a/lib/Net/DRI/DRD/NameAction.pm +++ b/lib/Net/DRI/DRD/NameAction.pm @@ -1,6 +1,6 @@ -## Domain Registry Interface, OpenSRS Registry Driver +## Domain Registry Interface, NameAction Registry Driver ## -## Copyright (c) 2008-2014 Patrick Mevzek . All rights reserved. +## Copyright (c) 2022 Paulo Castanheira . All rights reserved. ## ## This file is part of Net::DRI ## @@ -26,21 +26,17 @@ use Net::DRI::Util; =head1 NAME -Net::DRI::DRD::OpenSRS - OpenSRS Registry driver for Net::DRI +Net::DRI::DRD::NameAction - NameAction Registry driver for Net::DRI =head1 DESCRIPTION Please see the README file for details. -=head2 CURRENT LIMITATIONS - -Only domain_info and account_list_domains are available. - =head1 SUPPORT For now, support questions should be sent to: -Enetdri@dotandco.comE +Epaulo.s.castanheira@gmail.comE Please also see the SUPPORT file in the distribution. @@ -50,11 +46,11 @@ Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR -Patrick Mevzek, Enetdri@dotandco.comE +Paulo Castanheira, Epaulo.s.castanheira@gmail.comE =head1 COPYRIGHT -Copyright (c) 2008-2014 Patrick Mevzek . +Copyright (c) 2022 Paulo Castanheira . All rights reserved. This program is free software; you can redistribute it and/or modify @@ -77,7 +73,6 @@ sub new sub periods { return map { DateTime::Duration->new(years => $_) } (1..10); } sub name { return 'NameAction'; } -## See http://opensrs.com/site/services/domains/pricing sub tlds { return (qw/cl/, ); } sub object_types { return ('domain'); } @@ -91,96 +86,5 @@ sub transport_protocol_default return; } -#################################################################################################### - -sub domain_operation_needs_is_mine -{ - my ($self,$ndr,$domain,$op)=@_; - return; -} - -sub account_list_domains -{ - my ($self,$ndr)=@_; - my $rc=$ndr->try_restore_from_cache('account','domains','list'); - if (! defined $rc) { $rc=$ndr->process('account','list_domains'); } - return $rc; -} - -sub domain_info -{ - my ($self,$ndr,$domain,$rd)=@_; - $self->enforce_domain_name_constraints($ndr,$domain,'info'); - - my $rc=$ndr->try_restore_from_cache('domain',$domain,'info'); - if (! defined $rc) - { - ## First grab a cookie, if needed - unless (Net::DRI::Util::has_key($rd,'cookie')) - { - $rd=Net::DRI::Util::create_params('domain_info',$rd); ## will fail in set_cookie because other params needed, but at least this will be ok for next line ; otherwise do true checks of value needed - $rd->{domain}=$domain; - $rc=$ndr->process('session','set_cookie',[$rd]); - return $rc unless $rc->is_success(); - $rd->{cookie}=$ndr->get_info('value','session','cookie'); ## Store cookie somewhere (taking into account date of expiry or some TTLs) ? - } - ## Now do the real info - $rc=$ndr->process('domain','info',[$domain,$rd]); ## the $domain is not really used here, as it was used during set_cookie above - } - return $rc; -} - -sub domain_update -{ - my ($self,$ndr,$domain,$changes,$rd)=@_; - $self->enforce_domain_name_constraints($ndr,$domain,'update'); - - ## First grab a cookie, if needed - unless (Net::DRI::Util::has_key($rd,'cookie')) - { - $rd=Net::DRI::Util::create_params('domain_update',$rd); ## will fail in set_cookie because other params needed, but at least this will be ok for next line ; otherwise do true checks of value needed - $rd->{domain}=$domain; - my $rc=$ndr->process('session','set_cookie',[$rd]); - return $rc unless $rc->is_success(); - $rd->{cookie}=$ndr->get_info('value','session','cookie'); ## Store cookie somewhere (taking into account date of expiry or some TTLs) ? - } - ## Now do the real update - my $rc=$ndr->process('domain','update',[$domain,$changes,$rd]); ## the $domain is not really used here, as it was used during set_cookie above - return $rc; -} - -sub domain_is_mine -{ - my ($self,$ndr,$domain,$rd)=@_; - my $clid=$self->info('client_id'); - return unless defined $clid; - my $rc=$ndr->process('domain','is_mine',[$domain,$rd]); - return unless $rc->is_success(); - my $mine=$ndr->get_info('mine'); - return unless defined $mine; - return $mine; -} - -sub domain_send_authcode -{ - my ($self,$ndr,$domain)=@_; - my $rc=$ndr->process('domain','send_authcode',[$domain]); - return $rc; -} - -sub host_registry_check -{ - my ($self,$ndr,$hostname,$registry)=@_; - - return $ndr->process('nameserver', 'registry_check', [$hostname, $registry]); -} - -sub host_registry_add -{ - my ($self,$ndr,$hostname,$rd)=@_; - - return $ndr->process('nameserver', 'registry_add', [$hostname, $rd]); -} - #################################################################################################### 1; diff --git a/lib/Net/DRI/Protocol/NameAction.pm b/lib/Net/DRI/Protocol/NameAction.pm index 2da7e10a..9671b274 100644 --- a/lib/Net/DRI/Protocol/NameAction.pm +++ b/lib/Net/DRI/Protocol/NameAction.pm @@ -1,6 +1,6 @@ -## Domain Registry Interface, OpenSRS XCP Protocol +## Domain Registry Interface, NameAction Protocol ## -## Copyright (c) 2008-2010,2012,2013 Patrick Mevzek . All rights reserved. +## Copyright (c) 2022 Paulo Castanheira . All rights reserved. ## ## This file is part of Net::DRI ## @@ -25,7 +25,7 @@ use Net::DRI::Protocol::NameAction::Message; =head1 NAME -Net::DRI::Protocol::OpenSRS::XCP - OpenSRS XCP Protocol for Net::DRI +Net::DRI::Protocol::NameAction - NameAction Protocol for Net::DRI =head1 DESCRIPTION @@ -35,21 +35,17 @@ Please see the README file for details. For now, support questions should be sent to: -Enetdri@dotandco.comE +Epaulo.s.castanheira@gmail.comE Please also see the SUPPORT file in the distribution. -=head1 SEE ALSO - -Ehttp://www.dotandco.com/services/software/Net-DRI/E - =head1 AUTHOR -Patrick Mevzek, Enetdri@dotandco.comE +Paulo Castanheira, Epaulo.s.castanheira@gmail.comE =head1 COPYRIGHT -Copyright (c) 2008-2010,2012,2013 Patrick Mevzek . +Copyright (c) 2022 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify @@ -69,8 +65,10 @@ sub new my $drd=$ctx->{registry}->driver(); my $self=$c->SUPER::new($ctx); $self->name('nameaction'); - $self->version('1.0.4'); ## Specification March 17, 2008 + $self->version('1.0.4'); $self->factories('message',sub { my $m=Net::DRI::Protocol::NameAction::Message->new(); return $m; }); + $self->capabilities('domain_update','contact',['set']); + $self->capabilities('domain_update','ns',['set']); $self->_load($rp); return $self; } diff --git a/lib/Net/DRI/Protocol/NameAction/Connection.pm b/lib/Net/DRI/Protocol/NameAction/Connection.pm index faabd43f..4776a728 100644 --- a/lib/Net/DRI/Protocol/NameAction/Connection.pm +++ b/lib/Net/DRI/Protocol/NameAction/Connection.pm @@ -1,6 +1,6 @@ -## Domain Registry Interface, OpenSRS XCP Connection handling +## Domain Registry Interface, NameAction Connection handling ## -## Copyright (c) 2008-2010,2013 Patrick Mevzek . All rights reserved. +## Copyright (c) 2022 Paulo Castanheira . All rights reserved. ## ## This file is part of Net::DRI ## @@ -30,7 +30,7 @@ use Net::DRI::Protocol::ResultStatus; =head1 NAME -Net::DRI::Protocol::OpenSRS::XCP::Connection - OpenSRS XCP Connection handling for Net::DRI +Net::DRI::Protocol::NameAction::Connection - NameAction Connection handling for Net::DRI =head1 DESCRIPTION @@ -40,21 +40,17 @@ Please see the README file for details. For now, support questions should be sent to: -Enetdri@dotandco.comE +Epaulo.s.castanheira@gmail.comE Please also see the SUPPORT file in the distribution. -=head1 SEE ALSO - -Ehttp://www.dotandco.com/services/software/Net-DRI/E - =head1 AUTHOR -Patrick Mevzek, Enetdri@dotandco.comE +Paulo Castanheira, Epaulo.s.castanheira@gmail.comE =head1 COPYRIGHT -Copyright (c) 2008-2010,2013 Patrick Mevzek . +Copyright (c) 2022 Paulo Castanheira . All rights reserved. This program is free software; you can redistribute it and/or modify diff --git a/lib/Net/DRI/Protocol/NameAction/Domain.pm b/lib/Net/DRI/Protocol/NameAction/Domain.pm index 918ac67c..44d14d2a 100644 --- a/lib/Net/DRI/Protocol/NameAction/Domain.pm +++ b/lib/Net/DRI/Protocol/NameAction/Domain.pm @@ -1,7 +1,6 @@ -## Domain Registry Interface, OpenSRS XCP Domain commands +## Domain Registry Interface, NameAction Domain commands ## -## Copyright (c) 2008-2011 Patrick Mevzek . All rights reserved. -## (c) 2012-2013 Dmitry Belyavsky . All rights reserved. +## Copyright (c) 2022 Paulo Castanheira . All rights reserved. ## ## This file is part of Net::DRI ## @@ -26,7 +25,7 @@ use URI; =head1 NAME -Net::DRI::Protocol::OpenSRS::XCP::Domain - OpenSRS XCP Domain commands for Net::DRI +Net::DRI::Protocol::NameAction::Domain - NameAction Domain commands for Net::DRI =head1 DESCRIPTION @@ -36,22 +35,17 @@ Please see the README file for details. For now, support questions should be sent to: -Enetdri@dotandco.comE +Epaulo.s.castanheira@gmail.comE Please also see the SUPPORT file in the distribution. -=head1 SEE ALSO - -Ehttp://www.dotandco.com/services/software/Net-DRI/E - =head1 AUTHOR -Patrick Mevzek, Enetdri@dotandco.comE +Paulo Castanheira, Epaulo.s.castanheira@gmail.comE =head1 COPYRIGHT -Copyright (c) 2008-2011 Patrick Mevzek . - (c) 2012-2013 Dmitry Belyavsky . +Copyright (c) 2022 Paulo Castanheira . All rights reserved. This program is free software; you can redistribute it and/or modify @@ -69,555 +63,319 @@ sub register_commands { my ($class,$version)=@_; my %tmp=( - check => [\&check, \&check_parse ], - create => [ \&create, \&create_parse ], - renew => [ \&renew, \&renew_parse ], - transfer_request => [ \&transfer_request, \&transfer_request_parse ], - update => [\&update, undef], #Modify - delete => [ \&delete, \&delete_parse ], + check => [\&check, \&parse ], + create => [ \&create, \&parse ], + renew => [ \&renew, \&parse ], + update => [\&update, \&parse], # Modify + transfer_request => [ \&transfer_request, \&parse ], + trade_request => [ \&trade_request, \&parse ], + delete => [ \&delete, \&parse ], info => [\&info, \&info_parse ], ); return { 'domain' => \%tmp }; } -sub build_msg_cookie -{ - my ($msg,$action,$cookie,$regip)=@_; - my %r=(action=>$action,object=>'domain',cookie=>$cookie); - $r{registrant_ip}=$regip if defined($regip); - $msg->command(\%r); - return; -} - -sub _build_command { - my ($mes,$action,$domain,$attrs) = @_; - Net::DRI::Exception->die(1,'NameAction/Domain',2,'Domain name needed') unless $domain; #FIXME handle multiple domains? see epp Util.pm - - my ($sdl, $tld) = ($domain =~ /^([^\.]+)\.(.+)$/); - my @fragments = ( 'Command' => ucfirst($action), #FIXME check if uppercase is really needed - 'SLD' => $sdl, - 'TLD' => $tld - ); - push @fragments, %$attrs if defined $attrs && ref $attrs eq 'HASH'; - return \@fragments -} - sub check { my ($nma,$domain,$rd)=@_; my $msg=$nma->message(); - my $cmd = _build_command($msg,'check',$domain); + my @attrs; + push @attrs,_build_domain($domain); + my $cmd = _build_command($msg,'check',\@attrs); $msg->command($cmd); return; } -sub check_parse +sub parse { my ($nma,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$nma->message(); return unless $mes->is_success(); - - $rinfo->{domain}->{$oname}->{action}='check'; - $rinfo->{domain}->{$oname}->{exist}=$mes->response_code() ? 0 : 1; - $rinfo->{domain}->{$oname}->{exist_reason}=$mes->response_text(); - return; -} - -sub info -{ - my ($xcp,$domain,$rd)=@_; - my $msg=$xcp->message(); - Net::DRI::Exception::usererr_insufficient_parameters('A cookie is needed for domain_info') unless Net::DRI::Util::has_key($rd,'cookie'); - build_msg_cookie($msg,'get',$rd->{cookie},$rd->{registrant_ip}); - my $info_type=exists $rd->{type} ? $rd->{type} : 'all_info'; - $msg->command_attributes({type => $info_type}); + +#use Data::Dumper;print Dumper( $mes); + $rinfo->{domain}->{$oname}->{action}=$oaction; + $rinfo->{domain}->{$oname}->{exist}=$oaction eq 'check'?($mes->response_code() ? 0 : 1):1; return; } -sub info_parse -{ - my ($xcp,$otype,$oaction,$oname,$rinfo)=@_; - my $mes=$xcp->message(); - return unless $mes->is_success(); - - $rinfo->{domain}->{$oname}->{action}='info'; - $rinfo->{domain}->{$oname}->{exist}=1; - my $ra=$mes->response_attributes(); ## Not parsed: dns_errors, descr - - my %d=(registry_createdate => 'crDate', registry_expiredate => 'exDate', registry_updatedate => 'upDate', registry_transferdate => 'trDate', expiredate => 'exDateLocal'); - while (my ($k,$v)=each(%d)) - { - next unless exists($ra->{$k}); - $ra->{$k}=~s/\s+/T/; ## with a little effort we become ISO8601 - $rinfo->{domain}->{$oname}->{$v}=$xcp->parse_iso8601($ra->{$k}); - } - - my $ns=$ra->{nameserver_list}; - if (defined($ns) && ref($ns) && @$ns) - { - my $nso=$xcp->create_local_object('hosts'); - foreach my $h (@$ns) - { - $nso->add($h->{name},[$h->{ipaddress}]); - } - $rinfo->{domain}->{$oname}->{ns}=$nso; - } - foreach my $bool (qw/sponsoring_rsp auto_renew let_expire/) - { - next unless exists($ra->{$bool}); - $rinfo->{domain}->{$oname}->{$bool}=$ra->{$bool}; - } - my $c=$ra->{contact_set}; - if (defined($c) && ref($c) && keys(%$c)) +sub create +{ + my ($nma,$domain,$rd)=@_; + my @attrs; + push @attrs,_build_domain($domain); + + Net::DRI::Exception::usererr_insufficient_parameters('duration is mandatory') unless Net::DRI::Util::has_duration($rd); + push @attrs, _build_duration($rd->{duration}->years()); + + Net::DRI::Exception::usererr_insufficient_parameters('contacts are mandatory') unless Net::DRI::Util::has_contact($rd); + foreach my $type (qw/registrant admin tech/) { - my $cs=$xcp->create_local_object('contactset'); - while (my ($type,$v)=each(%$c)) - { - my $c=parse_contact($xcp,$v); - $cs->add($c,$type eq 'owner'? 'registrant' : $type); - } - $rinfo->{domain}->{$oname}->{contact}=$cs; + my $co=$rd->{contact}->get($type); + Net::DRI::Exception::usererr_insufficient_parameters($type . ' contact is mandatory') unless Net::DRI::Util::isa_contact($co); + push @attrs,_build_contact($co,$type); } + + Net::DRI::Exception::usererr_insufficient_parameters('at least 2 nameservers are mandatory') unless Net::DRI::Util::isa_hosts($rd->{ns}) && $rd->{ns}->count()>=2; # Name servers are optional; if present must be >=2 + push @attrs, _build_all_ns($rd->{ns}); - # Status data is available for the separate request - foreach my $opensrs_status (qw/parkp_status lock_state can_modify domain_supports transfer_away_in_progress auctionescrow/) - { - next unless exists $ra->{$opensrs_status}; - $rinfo->{domain}->{$oname}->{$opensrs_status}=$ra->{$opensrs_status}; + if ( exists $rd->{info_pl} ) { + push @attrs,_build_info_pl( $rd->{info_pl} ); } + + my $msg=$nma->message(); + my $cmd = _build_command($msg,'create',\@attrs); + $msg->command($cmd); return; } -sub parse_contact -{ - my ($xcp,$rh)=@_; - my $c=$xcp->create_local_object('contact'); - ## No ID given back ! Waouh that is great... not ! - $c->firstname($rh->{first_name}); - $c->name($rh->{last_name}); - $c->org($rh->{org_name}) if exists($rh->{org_name}); - $c->street([map { $rh->{'address'.$_} } grep {exists($rh->{'address'.$_}) && defined($rh->{'address'.$_}) } (1,2,3)]); - $c->city($rh->{city}) if exists($rh->{city}); - $c->sp($rh->{state}) if exists($rh->{state}); - $c->pc($rh->{postal_code}) if exists($rh->{postal_code}); - $c->cc($rh->{country}) if exists($rh->{country}); - $c->voice($rh->{phone}) if exists($rh->{voice}); - $c->fax($rh->{fax}) if exists($rh->{fax}); - $c->email($rh->{email}) if exists($rh->{email}); - $c->url($rh->{url}) if exists($rh->{url}); - return $c; -} - -sub create +sub renew { my ($nma,$domain,$rd)=@_; - my $msg=$nma->message(); + my @attrs; - my $cmd = _build_command($msg,'create',$domain); + push @attrs,_build_domain($domain); + + Net::DRI::Exception::usererr_insufficient_parameters('duration is mandatory') unless Net::DRI::Util::has_duration($rd); + push @attrs, _build_duration($rd->{duration}->years()); + + my $msg=$nma->message(); + my $cmd = _build_command($msg,'renew',\@attrs); $msg->command($cmd); return; } -sub create_parse -{ - my ($nma,$otype,$oaction,$oname,$rinfo)=@_; - my $mes=$nma->message(); - return unless $mes->is_success(); - - $rinfo->{domain}->{$oname}->{action}='create'; - $rinfo->{domain}->{$oname}->{exist}=$mes->response_code() ? 0 : 1; - $rinfo->{domain}->{$oname}->{exist_reason}=$mes->response_text(); - return; -} - -sub sw_register +sub update { - my ($xcp,$domain,$rd,$reg_type)=@_; - - my $msg=$xcp->message(); - - my %r=(action => 'sw_register', object => 'domain'); - $r{registrant_ip}=$rd->{registrant_ip} if exists $rd->{registrant_ip}; - - $msg->command(\%r); - - Net::DRI::Exception::usererr_insufficient_parameters('Username+Password are required for sw_register') if grep { ! Net::DRI::Util::has_key($rd,$_) } qw/username password/; - - Net::DRI::Exception::usererr_insufficient_parameters('contacts are mandatory') unless Net::DRI::Util::has_contact($rd); - my $cs=$rd->{contact}; - foreach my $t (qw/registrant admin billing/) + my ($nma,$domain,$rd)=@_; + my @attrs; + + push @attrs,_build_domain($domain); + + Net::DRI::Exception::usererr_invalid_parameters($rd.' must be a non empty Net::DRI::Data::Changes object') unless Net::DRI::Util::isa_changes($rd); + my $cs=$rd->set('contact'); + Net::DRI::Exception::usererr_invalid_parameters('contact changes for set must be a Net::DRI::Data::ContactSet') unless defined($cs) && Net::DRI::Util::isa_contactset($cs); + + foreach my $type (qw/registrant admin tech/) { - my @t=$cs->get($t); - Net::DRI::Exception::usererr_invalid_parameters('one ' . $t . ' contact is mandatory') unless @t==1; - my $co=$cs->get($t); - Net::DRI::Exception::usererr_insufficient_parameters($t . 'contact is mandatory') unless Net::DRI::Util::isa_contact($co); - $co->validate(); - } - - my %contact_set = (); - my $attr = {reg_type => $reg_type, domain => $domain, contact_set => \%contact_set}; - $contact_set{owner} = add_owner_contact($msg,$cs); - $contact_set{admin} = add_admin_contact($msg,$cs); - $contact_set{billing} = add_billing_contact($msg,$cs); - if ($cs->get('tech')) { - $contact_set{tech} = add_tech_contact($msg,$cs); ## optional - $attr->{custom_tech_contact} = 1; - } else { - $attr->{custom_tech_contact} = 0; # Use default tech contact - } - - # These are all the OpenSRS names for optional parameters. Might need to map generic names to OpenSRS namespace later. - foreach (qw/auto_renew affiliate_id f_lock_domain f_parkp f_whois_privacy/) { - $attr->{$_} = ($rd->{$_} ? 1 : 0 ) if Net::DRI::Util::has_key($rd, $_); + my $co=$cs->get($type); + next if !$co; + Net::DRI::Exception::usererr_insufficient_parameters($co.' is not a '.$type.' contact') unless Net::DRI::Util::isa_contact($co); + push @attrs,_build_contact($co,$type); } - foreach (qw/affiliate_id reg_domain encoding_type tld_data/) { - $attr->{$_} = ($rd->{$_}) if Net::DRI::Util::has_key($rd, $_); - } - - if (Net::DRI::Util::has_key($rd, 'f_bypass_confirm') && Net::DRI::Util::has_auth($rd)) { - $attr->{'f_bypass_confirm'} = 1; - $attr->{'auth_info'} = $rd->{'auth'}->{'pw'}; - } - - # TBD: ccTLD-specific flags including domain encoding. - # TBD: handle, link_domains, etc. - - if ($reg_type eq 'new') { - Net::DRI::Exception::usererr_insufficient_parameters('duration is mandatory') unless Net::DRI::Util::has_duration($rd); - $attr->{period} = $rd->{duration}->years(); + + if ( my $ns=$rd->set('ns') ) + { + Net::DRI::Exception::usererr_invalid_parameters('ns changes for set must be a Net::DRI::Data::Hosts object') unless Net::DRI::Util::isa_hosts($ns); + push @attrs, _build_all_ns($ns); } - $attr->{reg_username} = $rd->{username}; - $attr->{reg_password} = $rd->{password}; - - $msg->command_attributes($attr); - - add_all_ns($domain,$msg,$rd->{ns}); + my $msg=$nma->message(); + my $cmd = _build_command($msg,'modify',\@attrs); + $msg->command($cmd); return; } -sub update +sub info { - my ($xcp,$domain,$todo,$rd)=@_; - - my $msg=$xcp->message(); - my $attr = { domain => $domain }; - $msg->command_attributes($attr); - - Net::DRI::Exception::usererr_invalid_parameters($todo.' must be a non empty Net::DRI::Data::Changes object') unless Net::DRI::Util::isa_changes($todo); - Net::DRI::Exception::usererr_insufficient_parameters('A cookie is needed for domain_info') unless Net::DRI::Util::has_key($rd,'cookie'); + my ($nma,$domain,$rd)=@_; + my @attrs; + + push @attrs,_build_domain($domain); + + my $msg=$nma->message(); + my $cmd = _build_command($msg,'info',\@attrs); + $msg->command($cmd); + return; +} - my $nsset=$todo->set('ns'); - my $contactset=$todo->set('contact'); +sub info_parse +{ + my ($nma,$otype,$oaction,$oname,$rinfo)=@_; + my $mes=$nma->message(); + return unless $mes->is_success(); - if (defined $nsset) + $rinfo->{domain}->{$oname}->{action}=$oaction; + $rinfo->{domain}->{$oname}->{exist}=$mes->response_code() == 1000 ? 1 : 0; + + my $ra = $mes->response_attributes(); + my $cts=$ra->{contacts}; + if (defined($cts) && ref($cts) && keys(%$cts)) { - Net::DRI::Exception::usererr_invalid_parameters('ns changes for set must be a Net::DRI::Data::Hosts object') unless Net::DRI::Util::isa_hosts($nsset); - Net::DRI::Exception::usererr_invalid_parameters('change of nameservers and contacts is not supported in the same operation') if defined $contactset; - Net::DRI::Exception::usererr_insufficient_parameters('at least 2 nameservers are mandatory') unless ($nsset->count()>=2); - - build_msg_cookie($msg,'advanced_update_nameservers',$rd->{cookie},$rd->{registrant_ip}); - $attr->{op_type}='assign'; - $attr->{assign_ns}=[ $nsset->get_names() ]; + my $cs=$nma->create_local_object('contactset'); + foreach my $type (keys %$cts) { + my $c=$nma->create_local_object('contact'); + $c->name($cts->{$type}); + $cs->add($c,$type); + } + $rinfo->{domain}->{$oname}->{contact}=$cs; } - else + + my $ns=$ra->{hosts}; + if (defined($ns) && ref($ns) && @$ns) { - Net::DRI::Exception::usererr_invalid_parameters('contact changes for set must be a Net::DRI::Data::ContactSet') unless defined($contactset) && Net::DRI::Util::isa_contactset($contactset); - - build_msg_cookie($msg,'update_contacts',$rd->{cookie},$rd->{registrant_ip}); - my %contact_set = (); - my $types = []; - foreach my $t (qw/registrant admin billing tech/) + my $nso=$nma->create_local_object('hosts'); + foreach my $h (@$ns) { - my @t=$contactset->get($t); - next unless @t==1; - my $co=$t[0]; - next unless Net::DRI::Util::isa_contact($co); - $co->validate(); - my $registry_type = $t eq 'registrant' ? 'owner' : $t; - $contact_set{$registry_type}=add_contact_info($msg,$co); - push @$types, $registry_type; + $nso->add($h->[0],[$h->[1]]); } - $attr->{contact_set} = \%contact_set; - $attr->{types} = $types; + $rinfo->{domain}->{$oname}->{ns}=$nso; } - return; -} - -sub add_contact_info -{ - my ($msg,$co)=@_; - my %contact = (); - - $contact{first_name} = $co->firstname(); - $contact{last_name} = $co->name(); - - $contact{org_name} = $co->org() if $co->org(); - - my $s=$co->street(); - Net::DRI::Exception::usererr_insufficient_parameters('1 line of address at least needed') unless ($s && (ref($s) eq 'ARRAY') && @$s && $s->[0]); - - $contact{address1} = $s->[0]; - $contact{address2} = $s->[1] if $s->[1]; - $contact{address3} = $s->[2] if $s->[2]; - Net::DRI::Exception::usererr_insufficient_parameters('city & cc mandatory') unless ($co->city() && $co->cc()); - $contact{city} = $co->city(); - #TODO state and postal_code are required for US/CA - $contact{state} = $co->sp() if $co->sp(); - $contact{postal_code} = $co->pc() if $co->pc(); - $contact{country} = uc($co->cc()); - Net::DRI::Exception::usererr_insufficient_parameters('voice & email mandatory') unless ($co->voice() && $co->email()); - $contact{phone} = $co->voice(); - $contact{fax} = $co->fax() if $co->fax(); - $contact{email} = $co->email(); - $contact{url} = $co->url() if $co->url(); - return \%contact; -} - -sub add_owner_contact -{ - my ($msg,$cs)=@_; - my $co=$cs->get('registrant'); - return add_contact_info($msg,$co) if Net::DRI::Util::isa_contact($co); - return; + + $rinfo->{domain}->{$oname}->{expirydate}=$ra->{expiry_date}; } -sub add_admin_contact +sub delete { - my ($msg,$cs)=@_; - my $co=$cs->get('admin'); - return add_contact_info($msg,$co) if Net::DRI::Util::isa_contact($co); + my ($nma,$domain,$rd)=@_; + my @attrs; + + push @attrs,_build_domain($domain); + + my $msg=$nma->message(); + my $cmd = _build_command($msg,'delete',\@attrs); + $msg->command($cmd); return; } -sub add_billing_contact +sub transfer_request { - my ($msg,$cs)=@_; - my $co=$cs->get('billing'); - return add_contact_info($msg,$co) if Net::DRI::Util::isa_contact($co); + my ($nma,$domain,$rd)=@_; + my @attrs; + + push @attrs,_build_type('management'); + push @attrs,_build_domain($domain); + + if (Net::DRI::Util::has_auth($rd)) { + Net::DRI::Exception::usererr_insufficient_parameters('registrant contact is mandatory') unless Net::DRI::Util::has_key($rd->{auth},'pw'); + push @attrs, _build_auth($rd->{auth}{pw}); + } + + my $msg=$nma->message(); + my $cmd = _build_command($msg,'transfer',\@attrs); + $msg->command($cmd); return; } -sub add_tech_contact -{ - my ($msg,$cs)=@_; - my $co=$cs->get('tech'); - return add_contact_info($msg,$co) if Net::DRI::Util::isa_contact($co); - return; -} -sub add_all_ns +sub trade_request { - my ($domain,$msg,$ns)=@_; - my @nslist = (); - - my $attr = $msg->command_attributes(); - $attr->{custom_nameservers} = 0; - - if (defined($ns)) { - Net::DRI::Exception::usererr_insufficient_parameters('at least 2 nameservers are mandatory') unless (Net::DRI::Util::isa_hosts($ns) && $ns->count()>=2); # Name servers are optional; if present must be >=2 + my ($nma,$domain,$rd)=@_; + my @attrs; + + push @attrs,_build_type('owner'); + push @attrs,_build_domain($domain); - for (my $i = 1; $i <= $ns->count(); $i++) { # Net:DRI name server list starts at 1. - my $name = $ns->get_details($i); # get_details in scalar returns name - push @nslist, { sortorder => $i, name => $name }; - } - $attr->{custom_nameservers} = 1; - $attr->{nameserver_list} = \@nslist; + Net::DRI::Exception::usererr_insufficient_parameters('registrant contact is mandatory') unless Net::DRI::Util::has_contact($rd) && Net::DRI::Util::isa_contact($rd->{contact}->get('registrant')); + + foreach my $type (qw/registrant admin tech/) + { + my $co=$rd->{contact}->get($type); + next if !$co; + Net::DRI::Exception::usererr_insufficient_parameters($co.' is not a '.$type.' contact') unless Net::DRI::Util::isa_contact($co); + push @attrs,_build_contact($co,$type); } - $msg->command_attributes($attr); + + if ( Net::DRI::Util::has_ns($rd) ) + { + push @attrs, _build_all_ns($rd->{ns}); + } + + my $msg=$nma->message(); + my $cmd = _build_command($msg,'transfer',\@attrs); + $msg->command($cmd); return; } -sub delete ## no critic (Subroutines::ProhibitBuiltinHomonyms) +sub _build_domain { - my ($xcp,$domain,$rd)=@_; - my $msg=$xcp->message(); - - Net::DRI::Exception::usererr_insufficient_parameters('Reseller ID is mandatory') unless (Net::DRI::Util::has_key($rd, 'reseller_id')); - - my %r=(action => 'revoke', object => 'domain'); - $r{registrant_ip}=$rd->{registrant_ip} if exists $rd->{registrant_ip}; - - $msg->command(\%r); - my $attr = {domain => $domain, reseller => $rd->{reseller_id}}; - $attr->{notes} = $rd->{notes} if Net::DRI::Util::has_key($rd, 'notes'); - $msg->command_attributes({domain => $domain, reseller => $rd->{reseller_id}}); - return; + my ($domain) = @_; + Net::DRI::Exception->die(1,'NameAction/Domain',2,'Domain name needed') unless $domain; #FIXME check is domain + + my ($sdl, $tld) = ($domain =~ /^([^\.]+)\.(.+)$/); + return ( 'SLD' => $sdl, + 'TLD' => $tld + ); } -sub delete_parse +sub _build_command { - my ($xcp,$otype,$oaction,$oname,$rinfo)=@_; - my $mes=$xcp->message(); - return unless $mes->is_success(); + my ($mes,$action,$attrs) = @_; - $rinfo->{domain}->{$oname}->{action}='delete'; - my $ra=$mes->response_attributes(); - foreach (qw/charge price/) { - $rinfo->{domain}->{$oname}->{$_} = $ra->{$_} if exists $ra->{$_}; - } - return; + my @fragments = ( 'Command' => ucfirst($action)); + push @fragments, @$attrs if defined $attrs && ref $attrs eq 'ARRAY'; + return \@fragments } -sub renew -{ - my ($xcp,$domain,$rd)=@_; - my $msg=$xcp->message(); - - my %r=(action => 'renew', object => 'domain'); - $r{registrant_ip}=$rd->{registrant_ip} if exists $rd->{registrant_ip}; - - Net::DRI::Exception::usererr_insufficient_parameters('auto_renew setting is mandatory') unless (Net::DRI::Util::has_key($rd, 'auto_renew')); - - Net::DRI::Exception::usererr_insufficient_parameters('duration is mandatory') unless Net::DRI::Util::has_duration($rd); - Net::DRI::Exception::usererr_insufficient_parameters('current expiration is mandatory') unless (Net::DRI::Util::has_key($rd, 'current_expiration') && Net::DRI::Util::check_isa($rd->{current_expiration}, 'DateTime')); # Can get this from set_cookie response. - my $attr = {domain => $domain, period => $rd->{duration}->years(), currentexpirationyear => $rd->{current_expiration}->year()}; - # These are all the OpenSRS names for optional parameters. Might need to map generic names to OpenSRS namespace later. - foreach (qw/auto_renew f_parkp/) { - $attr->{$_} = ($rd->{$_} ? 1 : 0 ) if Net::DRI::Util::has_key($rd, $_); - } - foreach (qw/affiliate_id notes/) { - $attr->{$_} = ($rd->{$_}) if Net::DRI::Util::has_key($rd, $_); - } +sub _build_contact { + my ($contact,$type) = @_; + my $add_ref = $contact->street(); + Net::DRI::Exception::usererr_insufficient_parameters('at least 1 line of address is needed') unless $add_ref && ref($add_ref) eq 'ARRAY' && @$add_ref && $add_ref->[0]; - $rd->{handle} ||= 'process'; - $attr->{handle} = $rd->{handle}; - # TBD: handle, etc. + my @fragments = ( + ucfirst($type).'Name' => $contact->name(), + ucfirst($type).'Organization' => $contact->org(), + ucfirst($type).'Address' => join(' ', grep {$_} @$add_ref), + ucfirst($type).'City' => $contact->city(), + ucfirst($type).'CountryCode' => $contact->cc(), + ucfirst($type).'PostalCode' => $contact->pc(), + ucfirst($type).'Phone' => $contact->voice(), + ucfirst($type).'Email' => $contact->email(), + ); - $msg->command(\%r); - $msg->command_attributes($attr); - return; + return @fragments; } -sub renew_parse +sub _build_all_ns { - my ($xcp,$otype,$oaction,$oname,$rinfo)=@_; - my $mes=$xcp->message(); - return unless $mes->is_success(); - - $rinfo->{domain}->{$oname}->{action}='renew'; - my $ra=$mes->response_attributes(); - foreach (qw/auto_renew admin_email order_id id queue_request_id/) { - $rinfo->{domain}->{$oname}->{$_} = $ra->{$_} if exists $ra->{$_}; + my ($ns)=@_; + + Net::DRI::Exception::usererr_insufficient_parameters('max 6 nameservers exceeded') unless $ns->count()<=6; + + my (@hostnames,@ipv4); + for (my $i = 1; $i <= $ns->count(); $i++) { # Net:DRI name server list starts at 1. + my ($hostname, $ipv4) = $ns->get_details($i); + + Net::DRI::Exception::usererr_insufficient_parameters("invalid host $1 hostname") unless Net::DRI::Util::is_hostname($hostname); + Net::DRI::Exception::usererr_insufficient_parameters('invalid host $1 ipv4') unless Net::DRI::Util::is_ipv4($ipv4->[0]); + push @hostnames, ('NS'.$i => $hostname); + + push @ipv4, ('IP'.$i => $ipv4->[0]) ; } - my ($k,$v)=('registration expiration date', 'exDate'); - $ra->{$k}=~s/\s+/T/; ## with a little effort we become ISO8601 - $rinfo->{domain}->{$oname}->{$v}=$xcp->parse_iso8601($ra->{$k}) if defined($ra->{$k}); - return; -} - -sub transfer_request -{ - my ($xcp,$domain,$rd)=@_; - sw_register($xcp, $domain, $rd, 'transfer'); - return; + return @hostnames, @ipv4; } -sub transfer_request_parse -{ - my ($xcp,$otype,$oaction,$oname,$rinfo)=@_; - my $mes=$xcp->message(); - return unless $mes->is_success(); - $rinfo->{domain}->{$oname}->{action}='transfer_start'; - my $ra=$mes->response_attributes(); - foreach (qw/admin_email cancelled_orders error id queue_request_id forced_pending whois_privacy/) { - $rinfo->{domain}->{$oname}->{$_} = $ra->{$_} if exists $ra->{$_}; - } - return; -} -sub transfer_query +sub _build_duration { - my ($xcp,$domain,$rd)=@_; - my $msg=$xcp->message(); - - my %r=(action => 'check_transfer', object => 'domain'); - $r{registrant_ip}=$rd->{registrant_ip} if exists $rd->{registrant_ip}; - - $msg->command(\%r); - $msg->command_attributes({domain => $domain, check_status => 1, get_request_address => 1}); # TBD: usable for checking transferability - return; + my ($years) = @_; + return ( Year => $years); } -sub transfer_query_parse +sub _build_info_pl { - my ($xcp,$otype,$oaction,$oname,$rinfo)=@_; - my $mes=$xcp->message(); - return unless $mes->is_success(); - - $rinfo->{domain}->{$oname}->{action}='check_transfer'; - my $ra=$mes->response_attributes(); - foreach (qw/transferrable status request_address timestamp unixtime reason type noservice/) { - $rinfo->{domain}->{$oname}->{$_} = $ra->{$_} if exists $ra->{$_}; - } - return; + my ($info_pl) = @_; + return ( InfoPL => $info_pl ); } -sub transfer_cancel -{ - my ($xcp,$domain,$rd)=@_; - my $msg=$xcp->message(); - - Net::DRI::Exception::usererr_insufficient_parameters('Reseller ID is mandatory') unless (Net::DRI::Util::has_key($rd, 'reseller_id')); - - my %r=(action => 'cancel_transfer', object => 'transfer'); - $r{registrant_ip}=$rd->{registrant_ip} if exists $rd->{registrant_ip}; - - $msg->command(\%r); - $msg->command_attributes({domain => $domain, reseller => $rd->{reseller_id}}); # TBD: optional order ID - return; -} - -sub transfer_cancel_parse -{ - my ($xcp,$otype,$oaction,$oname,$rinfo)=@_; - my $mes=$xcp->message(); - return unless $mes->is_success(); - - $rinfo->{domain}->{$oname}->{action}='cancel_transfer'; - # This response has no attributes to capture - return; -} -sub is_mine +sub _build_auth { - my ($xcp,$domain,$rd)=@_; - my $msg=$xcp->message(); - - # Cookie isn't used with belongs_to_rsp - - $msg->command ({ action => 'belongs_to_rsp' }); - $msg->command_attributes ({ domain => $domain }); - return; + my ($auth) = @_; + return ( AuthCode => $auth ); } -sub is_mine_parse +sub _build_type { - my ($xcp,$otype,$oaction,$oname,$rinfo)=@_; - my $mes=$xcp->message(); - return unless $mes->is_success(); - - $rinfo->{domain}->{$oname}->{action} = 'is_mine'; - $rinfo->{domain}->{$oname}->{exist} = 1; - - my $ra=$mes->response_attributes(); - return unless exists $ra->{belongs_to_rsp} && defined $ra->{belongs_to_rsp}; - - $rinfo->{domain}->{$oname}->{mine}=($ra->{belongs_to_rsp})? 1 : 0; - if (exists $ra->{domain_expdate} && defined $ra->{domain_expdate}) ## only here if belongs_to_rsp=1 - { - my $d=$ra->{domain_expdate}; - $d=~s/\s+/T/; ## with a little effort we become ISO8601 - $rinfo->{domain}->{$oname}->{exDate}=$xcp->parse_iso8601($d); - } - return; + my ($type) = @_; + Net::DRI::Exception::usererr_insufficient_parameters('type must be owner/management') unless grep {/^$type$/} qw/owner management/; + return (Type => ucfirst($type)); } #################################################################################################### diff --git a/lib/Net/DRI/Protocol/NameAction/Message.pm b/lib/Net/DRI/Protocol/NameAction/Message.pm index 1b8b2f7b..a51c8d42 100644 --- a/lib/Net/DRI/Protocol/NameAction/Message.pm +++ b/lib/Net/DRI/Protocol/NameAction/Message.pm @@ -1,6 +1,6 @@ -## Domain Registry Interface, OpenSRS XCP Message +## Domain Registry Interface, NameAction Message ## -## Copyright (c) 2008-2010,2012-2014 Patrick Mevzek . All rights reserved. +## Copyright (c) 2022 Paulo Castanheira . All rights reserved. ## ## This file is part of Net::DRI ## @@ -25,13 +25,13 @@ use Net::DRI::Exception; use Net::DRI::Util; use base qw(Class::Accessor::Chained::Fast Net::DRI::Protocol::Message); -__PACKAGE__->mk_accessors(qw(version client_auth command command_attributes response_code response_text response_command response_is_success)); +__PACKAGE__->mk_accessors(qw(version client_auth command command_attributes response_code response_text response_command response_attributes response_is_success)); =pod =head1 NAME -Net::DRI::Protocol::OpenSRS::XCP::Message - OpenSRS XCP Message for Net::DRI +Net::DRI::Protocol::NameAction::Message - NameAction Message for Net::DRI =head1 DESCRIPTION @@ -51,11 +51,11 @@ Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR -Patrick Mevzek, Enetdri@dotandco.comE +Paulo Castanheira, Epaulo.s.castanheira@gmail.comE =head1 COPYRIGHT -Copyright (c) 2008-2010,2012-2014 Patrick Mevzek . +Copyright (c) 2022 Paulo Castanheira . All rights reserved. This program is free software; you can redistribute it and/or modify @@ -79,47 +79,12 @@ sub new return $self; } -our %CODES=( 200 => 1000, - 210 => 2303, - 211 => 2302, - 212 => 1000, - 221 => 2302, - 250 => 1001, - 300 => 1001, - 310 => 2502, - 350 => 2502, ## A maximum of 100 commands can be sent through one connection/session. After 100 commands have been submitted, the connection is closed and a new connection must be opened to submit outstanding requests. - 400 => 2400, - 404 => 2400, - 405 => 2400, - 410 => 2200, - 415 => 2200, - 430 => 2000, - 435 => 2201, - 436 => 2400, - 437 => 2304, - 440 => 2201, - 445 => 2201, - 447 => 2201, - 460 => 2003, - 465 => 2005, - 480 => 2306, - 485 => 2302, - 486 => 2304, - 487 => 2106, - 541 => 2004, - 552 => 2304, - 555 => 2306, - 557 => 2305, - 705 => 2400, - ); - sub result_status { my $self=shift; return Net::DRI::Protocol::ResultStatus->new_success($self->response_text()) if $self->response_is_success(); my $code=$self->response_code(); - my $eppcode=(defined $code && exists $CODES{$code})? $CODES{$code} : 'COMMAND_FAILED'; - return Net::DRI::Protocol::ResultStatus->new('opensrs_xcp',$code,$eppcode,$self->response_is_success(),$self->response_text(),'en'); + return Net::DRI::Protocol::ResultStatus->new('nameaction',$code,$code,$self->response_is_success(),$self->response_text(),'en'); } sub is_success { return shift->response_is_success(); } @@ -130,53 +95,9 @@ sub as_string { return $uri->query(); } -sub _obj2dt -{ - my ($in)=@_; - my @r; - foreach my $el ($in) - { - my $ref=ref($el); - if (!$ref) - { - push @r,sprintf('%s',Net::DRI::Util::xml_escape($el)); - } elsif ($ref eq 'HASH') - { - my @c; - foreach my $k (sort { $a cmp $b } keys %$el) - { - $k=~s/"/"/g; - my $v=$el->{$k}; - if (!defined($v)) { - push @c,sprintf('',$k); - } else { - push @c,sprintf('%s',$k,ref($v)? _obj2dt($v) : Net::DRI::Util::xml_escape($v)); - } - } - push @r,sprintf('%s',join('',@c)); - } elsif ($ref eq 'ARRAY') - { - my @c; - foreach my $i (0..$#$el) - { - push @c,sprintf('%s',$i,ref($el->[$i])? _obj2dt($el->[$i]) : Net::DRI::Util::xml_escape($el->[$i])); - } - push @r,sprintf('%s',join('',@c)); - } elsif ($ref eq 'SCALAR') - { - push @r,sprintf('%s',Net::DRI::Util::xml_escape($$el)); ## defined in specifications, but not really used ? - } else - { - Net::DRI::Exception::err_assert('_obj2dt cannot deal with data '.$el); - } - } - return @r; -} - sub parse { my ($self,$dr,$rinfo,$otype,$oaction,$msgsent)=@_; - #use Data::Dumper; print Dumper(@_); $self->command($msgsent->command()); ## Copy over for reference from message sent my $parser=XML::LibXML->new(); @@ -186,19 +107,77 @@ sub parse Net::DRI::Exception->die(0,'protocol/NameAction',1,'Unsuccessful parse, root element is not "nck" but '.$root->getName()) unless ($root->getName() eq 'nck'); my $resp = $root->getElementsByTagName('response'); - Net::DRI::Exception->die(0,'protocol/NameAction',1,'Unsuccessful parse, expected only one "response" node below root, found '.$resp->size()) unless ($resp->size()==1); + Net::DRI::Exception->die(0,'protocol/NameAction',1,'Unsuccessful parse, expected one "response" node below root, found '.$resp->size()) unless ($resp->size()==1); + + my $error = $resp->get_node(1)->getChildrenByTagName('error'); + if ( $error->size() ) + { + my $code = $error->get_node(1)->getChildrenByTagName('code'); + Net::DRI::Exception->die(0,'protocol/NameAction',1,'Unsuccessful parse, expected one "code" node below "error", found '.$code->size()) unless ($code->size()==1); + $self->response_code($code->get_node(0)->textContent()); + + my $msg = $error->get_node(1)->getChildrenByTagName('message'); + Net::DRI::Exception->die(0,'protocol/NameAction',1,'Unsuccessful parse, expected one "message" node below "error", found '.$msg->size()) unless ($code->size()==1); + $self->response_text($msg->get_node(0)->textContent()); + + $self->response_is_success(0); + return; + } my $cmd = $resp->get_node(1)->getChildrenByTagName('command'); - Net::DRI::Exception->die(0,'protocol/NameAction',1,'Unsuccessful parse, expected only one "command" node below responset, found '.$cmd->size()) unless ($cmd->size()==1); + Net::DRI::Exception->die(0,'protocol/NameAction',1,'Unsuccessful parse, expected one "command" node below "response", found '.$cmd->size()) unless ($cmd->size()==1); $self->response_command($cmd->get_node(0)->textContent()); my $val = $resp->get_node(1)->getChildrenByTagName('value'); - Net::DRI::Exception->die(0,'protocol/NameAction',1,'Unsuccessful parse, expected only one "value" node below responset, found '.$val->size()) unless ($val->size()==1); + Net::DRI::Exception->die(0,'protocol/NameAction',1,'Unsuccessful parse, expected one "value" node below "response", found '.$val->size()) unless ($val->size()==1); $self->response_code($val->get_node(0)->textContent()); my $msg=$root->getElementsByTagName('message'); - Net::DRI::Exception->die(0,'protocol/NameAction',1,'Unsuccessful parse, expected only one "message" node below root, found '.$msg->size()) unless ($msg->size()==1); - $self->response_text($msg->get_node(0)->textContent()); + Net::DRI::Exception->die(0,'protocol/NameAction',1,'Unsuccessful parse, expected one "message" node below root, found '.$msg->size()) unless ($msg->size()==1); + + if ( $oaction ne 'info' ) { + $self->response_text($msg->get_node(0)->textContent()); + } + else + { + my $details = $msg->get_node(1)->getChildrenByTagName('details'); + Net::DRI::Exception->die(0,'protocol/NameAction',1,'Unsuccessful parse, expected one "details" node below "message", found '.$details->size()) unless ($details->size()==1); + + my $conts_tag = $details->get_node(1)->getChildrenByTagName('contacts'); + Net::DRI::Exception->die(0,'protocol/NameAction',1,'Unsuccessful parse, expected one "contacts" node below "details", found '.$conts_tag->size()) unless ($conts_tag->size()==1); + my $conts = $conts_tag->get_node(1)->getChildrenByTagName('*'); + Net::DRI::Exception->die(0,'protocol/NameAction',1,'Unsuccessful parse, expected at least one contact node below "contacts", found '.$conts->size()) unless ($conts->size()>=1); + my %contacts; + foreach my $cont ($conts->get_nodelist()) { + $contacts{$cont->nodeName()} = $cont->textContent(); + } + + my $hosts_tag = $details->get_node(1)->getChildrenByTagName('hosts'); + Net::DRI::Exception->die(0,'protocol/NameAction',1,'Unsuccessful parse, expected one "hosts" node below "details", found '.$hosts_tag->size()) unless ($hosts_tag->size()==1); + my $hosts = $hosts_tag->get_node(1)->getChildrenByTagName('*'); + Net::DRI::Exception->die(0,'protocol/NameAction',1,'Unsuccessful parse, expected at least one host node below "hosts", found '.$hosts->size()) unless ($hosts->size()>=1); + my @hosts = (); + foreach my $node ($hosts->get_nodelist()) { + my ($what,$index) = $node->nodeName() =~ /^(\w+)(\d)$/; + if ( $what eq 'ns' ) { + $hosts[$index] = [$node->textContent()]; + } else { #IP + $hosts[$index][1] = $node->textContent(); + } + } + + my $exp_date = $details->get_node(1)->getChildrenByTagName('expirydate'); + Net::DRI::Exception->die(0,'protocol/NameAction',1,'Unsuccessful parse, expected one "expirydate" node below "details", found '.$exp_date->size()) unless ($exp_date->size()==1); + + my $status = $details->get_node(1)->getChildrenByTagName('status'); + Net::DRI::Exception->die(0,'protocol/NameAction',1,'Unsuccessful parse, expected one "status" node below "details", found '.$status->size()) unless ($status->size()==1); + + $self->response_attributes({ contacts => \%contacts, + hosts => \@hosts, + expiry_date => $exp_date->get_node(0)->textContent(), + status => $status->get_node(0)->textContent() + }); + } $self->response_is_success(1); return; diff --git a/t/Net/DRI/Protocol/NameAction.t b/t/Net/DRI/Protocol/NameAction.t index c66b0400..73c50fb4 100755 --- a/t/Net/DRI/Protocol/NameAction.t +++ b/t/Net/DRI/Protocol/NameAction.t @@ -12,9 +12,7 @@ use Test::More tests => 45; eval { no warnings; require Test::LongString; Test::LongString->import(max => 100); $Test::LongString::Context=50; }; if ( $@ ) { no strict 'refs'; *{'main::is_string'}=\&main::is; } - our ($R1,$R2); -our (@R1,@R2); #FIXME sub mysend { my ($transport,$count,$msg,$ctx)=@_; *{Net::DRI::Transport::Dummy::transport_data} = sub { return {remote_url => 'https://ncktest.nameaction.com/interface', @@ -24,16 +22,14 @@ sub mysend { my ($transport,$count,$msg,$ctx)=@_; return 1; } sub myrecv { return Net::DRI::Data::Raw->new_from_string($R2); } -sub munge { my $in=shift; $in=~s/>\s*new({cache_ttl => 10}); +my $dri=Net::DRI::TrapExceptions->new({cache_ttl => -1}); $dri->add_registry('NameAction'); -$dri->target('NameAction')->add_current_profile('p1','nameaction',{f_send=>\&mysend,f_recv=>\&myrecv});#,client_login=>'LOGIN',client_password=>'PASSWORD',remote_url=>'http://localhost/'}); +$dri->target('NameAction')->add_current_profile('p1','nameaction',{f_send=>\&mysend,f_recv=>\&myrecv});; my ($r,$rc,$rd,$ns,$cs); +$r = "https://ncktest.nameaction.com/interface?User=ncktest&Pass=ncktest&Command=Check&SLD=nameaction&TLD=cl"; $R2 = <<'EOF'; @@ -47,26 +43,23 @@ $R2 = <<'EOF'; EOF -$r=<<'EOF'; -EOF $rc=$dri->domain_check('nameaction.cl'); -is($R1,'https://ncktest.nameaction.com/interface?User=ncktest&Pass=ncktest&Command=Check&SLD=nameaction&TLD=cl','domain_check build'); +is($R1,$r,'domain_check build'); is($rc->is_success(),1,'domain_check is_success'); is($dri->get_info('action'),'check','domain_check get_info(action)'); is($dri->get_info('exist'),0,'domain_check get_info(exist)'); -is($dri->get_info('exist','domain','nameaction.cl'),0,'domain_check get_info(exist) from cache'); -#===Test registration with default name servers=================================== -$r=<<"EOF"; -https://ncktest.nameaction.com/interface?User=ncktest&Pass=ncktest&Command=Create&SLD=nameaction&TLD=cl&Year=1&RegistrantName=JohnDoe&RegistrantOrganization=NameAction DomainLA&RegistrantAddress=1156 HighStreet&RegistrantCity=California&RegistrantCountryCode=US&RegistrantPostalCode=95064&RegistrantPhone=1.1234567&RegistrantEmail=j.doenameaction.com&AdminName=John Doe&AdminOrganization=NameAction DomainLA&AdminAddress=1156 HighStreet&AdminCity=California&AdminCountryCode=US&AdminPostalCode=95064&AdminPhone=1.1234567&AdminEmail=j.doenameaction.com&TechName=JohnDoe&TechOrganization=NameAction Domain LA&TechAddress=1156 HighStreet&TechCity=California&TechCountryCode=US&TechPostalCode=95064&TechPhone=1.1234567&TechEmail=j.doenameaction.com&NS1=ns1.nameaction.com&NS2=ns2.nameaction.com&IP1=200.27.54.210&IP2=200.27.54.211&InfoPL=55555555-5 -EOF +### Create + +$r="https://ncktest.nameaction.com/interface?User=ncktest&Pass=ncktest&Command=Create&SLD=nameaction&TLD=cl&Year=2&RegistrantName=JohnDoe&RegistrantOrganization=NameAction+DomainLA&RegistrantAddress=1156+HighStreet&RegistrantCity=California&RegistrantCountryCode=US&RegistrantPostalCode=95064&RegistrantPhone=1.1234567&RegistrantEmail=j.doenameaction.com&AdminName=JohnDoe&AdminOrganization=NameAction+DomainLA&AdminAddress=1156+HighStreet&AdminCity=California&AdminCountryCode=US&AdminPostalCode=95064&AdminPhone=1.1234567&AdminEmail=j.doenameaction.com&TechName=JohnDoe&TechOrganization=NameAction+DomainLA&TechAddress=1156+HighStreet&TechCity=California&TechCountryCode=US&TechPostalCode=95064&TechPhone=1.1234567&TechEmail=j.doenameaction.com&NS1=ns1.nameaction.com&NS2=ns2.nameaction.com&IP1=200.27.54.210&IP2=200.27.54.211&InfoPL=55555555-5"; -push @R2,<<'EOF'; +$R2 = <<'EOF'; create - 1000 + 1000 + Request to Create the domain nameaction.cl was successfully received for 2 year(s). (Cost USD$95.0) @@ -74,499 +67,233 @@ push @R2,<<'EOF'; EOF $cs=$dri->local_object('contactset'); -my $reg_co=$dri->local_object('contact'); -#$reg_co->srid('daniel'); # Portfolio user name for OpenSRS? -#$reg_co->auth('daniel'); # Portfolio password for OpenSRS? -#$reg_co->name('Admin'); # Should be firstname, name => lastname. -$reg_co->name('John Doe'); -$reg_co->org('NameAction DomainLA'); -$reg_co->street(['1156 HighStreet','','']); -$reg_co->city('California'); -#$reg_co->sp('CA'); -$reg_co->pc('95064'); -$reg_co->cc('US'); -$reg_co->voice('1.1234567'); -#$reg_co->fax('+1.4165550125'); -$reg_co->email('j.doenameaction.com'); -#$reg_co->url('http://www.catmas.com'); - -$cs->set($reg_co,'registrant'); -$cs->set($reg_co,'admin'); -$cs->set($reg_co,'tech'); - -$ns = $dri->local_object('hosts')->set(['ns1.example.com',''],['ns1.example.net']); +my $co=$dri->local_object('contact'); +$co->name('JohnDoe'); +$co->org('NameAction DomainLA'); +$co->street(['1156 HighStreet','','']); +$co->city('California'); +$co->pc('95064'); +$co->cc('US'); +$co->voice('1.1234567'); +$co->email('j.doenameaction.com'); + +$cs->set($co,'registrant'); +$cs->set($co,'admin'); +$cs->set($co,'tech'); + +$ns = $dri->local_object('hosts')->set(['ns1.nameaction.com','200.27.54.210'],['ns2.nameaction.com','200.27.54.211']); $rc = $dri->domain_create('nameaction.cl',{ pure_create =>1, duration => DateTime::Duration->new(years=>2), ns => $ns, contact => $cs, - auth => {pw=>'2fooBAR'}}); + info_pl => '55555555-5' + }); is_string($R1,$r,'domain_create build'); -is($rc->is_success(),1,'domain_create is_success (default name servers)'); -is($rc->code(),1000,'domain_create code (default name servers)'); +is($rc->is_success(),1,'domain_create is_success'); is($dri->get_info('action'),'create','domain_create get_info(action)'); is($dri->get_info('exist'),1,'domain_create get_info(exist)'); -#is($dri->get_info('id'),3735281,'domain_create id'); -#is($rc->native_code(),200,'domain_create native_code (default name servers)'); -#is($dri->get_info_keys(),'admin_email','domain_create response keys'); -#is($dri->get_info('registration_code'),200,'domain_create get_info(registration_code)'); -#is($dri->get_info('domain','example-nsi.net','admin_email'),'jsmith@catmas.com','domain_create get_info(admin_email)'); -#is($dri->get_info('admin_email'),'jsmith@catmas.com','domain_create get_info(admin_email)'); - - - -exit 1; - -#===Test registration with default name servers=================================== - -push @R2,<<'EOF'; - - - -
- 0.9 -
- - - - XCP - REPLY - DOMAIN - 0 - 435 - - Request failed validation: Name server - 'dns1.example.com' is not found at the registry. Please double check - the nameserver and re-submit. - Name server 'dns2.example.com' is not found at the - registry. Please double check the nameserver and re-submit. - - - - - Request failed validation: Name server - 'dns1.example.com' is not found at the registry. Please double check - the nameserver and re-submit. - Name server 'dns2.example.com' is not found at the - registry. Please double check the nameserver and re-submit. - - 435 - 3735283 - 3735283 - - - - - - -EOF -$r=<<"EOF"; - - - -
- 0.9 -
- - - - sw_register - domain - XCP - 216.40.46.115 - - - - - - admin_co - - - admin_co - - - admin_co - - - - 1 - 0 - yahoo.com - - - - - ns1.domaindirect.com - 1 - - - - - ns2.domaindirect.com - 2 - - - - - 7 - daniel - new - daniel - - - - - - -EOF +### Renew -$ns=$dri->local_object('hosts'); -$ns->add('ns1.domaindirect.com',['123.45.67.89']); -$ns->add('ns2.domaindirect.com'); - -#SKIP: { -# skip 'dt_array bug', 3; -$rc=$dri->domain_create('yahoo.com',{username => 'daniel', password => 'daniel', contact => $cs, registrant_ip => '216.40.46.115', pure_create => 1, duration => DateTime::Duration->new(years =>7), ns => $ns}); -is_string(munge(shift(@R1)),munge($r),'domain_create (custom name servers)'); -is($rc->is_success(),0,'domain_create is_success (custom name servers)'); -#is($dri->get_info('response_code'),435,'domain_create get_info(response_code)'); -#is($dri->get_info('registration_code'),435,'domain_create get_info(registration_code)'); -#}; - -#===Test renew=================================== - -#pop @R2; - -push @R2,<<'EOF'; - - - -
-0.9 -
- - - -XCP -REPLY -DOMAIN - - -2006-01-08 15:35:00 -1 -admin1@example.com -3212624 -3511417 - - -Command completed successfully -1 -200 - - - - -EOF +$r="https://ncktest.nameaction.com/interface?User=ncktest&Pass=ncktest&Command=Renew&SLD=nameaction&TLD=cl&Year=2"; -$r=<<'EOF'; - - - -
-0.9 -
- - - -renew -domain -XCP -216.40.46.115 - - -1 -2009 -example.com -process -5 - - - - - - +$R2 = <<'EOF'; + + + renew + 1000 + + + Request to Renew the domain nameaction.cl was successfully received for 2 year(s). (Cost USD$80.0) + + EOF -$rc=$dri->domain_renew('example.com',{username => 'daniel', password => 'guessthis', registrant_ip => '216.40.46.115', auto_renew => 1, duration => DateTime::Duration->new(years =>5), current_expiration => DateTime->new( year => 2009, month => 06, day => 27)}); -is_string(munge(shift(@R1)),munge($r),'domain_renew'); +$rc = $dri->domain_renew('nameaction.cl',{duration => DateTime::Duration->new(years=>2)}); is($rc->is_success(),1,'domain_renew is_success'); -is($dri->get_info('admin_email'),'admin1@example.com','domain_renew get_info(admin_email)'); -is(''.$dri->get_info('exDate'),'2006-01-08T15:35:00','domain_info get_info(exDate)'); -#is($dri->get_info('registration expiration date'),'2006-12-07 00:00:00','domain_renew get_info(expiration date)'); - -#===Test revoke=================================== - -push @R2,<<'EOF'; - - - -
-0.9 -
- - - -XCP -REPLY -DOMAIN -1 - - -0 -undef - - -Domain test.com revoked successfully. -200 - - - - -EOF +is($R1,$r,'domain_renew build'); +is($dri->get_info('action'),'renew','domain_renew get_info(action)'); +is($dri->get_info('exist'),1,'domain_renew get_info(exist)'); -$r=<<"EOF"; - - - -
-0.9 -
- - - -revoke -domain -XCP -216.40.46.115 - - -example.com -$RESELLERID - - - - - - -EOF +### Update -$rc=$dri->domain_delete('example.com',{pure_delete => 1, username => 'daniel', password => 'guessthis', registrant_ip => '216.40.46.115', reseller_id => $RESELLERID}); -is_string(munge(shift(@R1)),munge($r),'domain_delete'); -is($rc->is_success(),1,'domain_delete is_success'); -is($dri->get_info('charge'),0,'domain_renew get_info(charge)'); - -#===Test transfer initiation=================================== - -push @R2,<<'EOF'; - - - -
-0.9 -
- - - -XCP -REPLY -DOMAIN -200 -Transfer request has been successfully sent -1 - - -Transfer request has been successfully sent -200 -3735288 - - - - - - -EOF +$r="https://ncktest.nameaction.com/interface?User=ncktest&Pass=ncktest&Command=Modify&SLD=nameaction&TLD=cl&RegistrantName=JohnDoe&RegistrantOrganization=NameAction+DomainLA&RegistrantAddress=1156+HighStreet&RegistrantCity=California&RegistrantCountryCode=US&RegistrantPostalCode=95064&RegistrantPhone=1.1234567&RegistrantEmail=j.doenameaction.com&AdminName=JohnDoe&AdminOrganization=NameAction+DomainLA&AdminAddress=1156+HighStreet&AdminCity=California&AdminCountryCode=US&AdminPostalCode=95064&AdminPhone=1.1234567&AdminEmail=j.doenameaction.com&NS1=ns1.nameaction.com&NS2=ns2.nameaction.com&IP1=200.27.54.210&IP2=200.27.54.211"; -$r=<<"EOF"; - - - -
-0.9 -
- - - -sw_register -domain -XCP -10.0.10.19 - - - - - - admin_co - - - admin_co - - - admin_co - - - -0 -0 -yahoo.com -example -transfer -example - - - - - - +$R2 = <<'EOF'; + + + modify + 1000 + + + Domain nameaction.cl successfully modified + + EOF -$rc=$dri->domain_transfer_start('yahoo.com',{username => 'example', password => 'example', contact => $cs, registrant_ip => '10.0.10.19'}); -is_string(munge(shift(@R1)),munge($r),'domain_transfer_start'); -is($rc->is_success(),1,'domain_transfer_start is_success'); -is($dri->get_info('id'),3735288,'domain_transfer_start get_info(id)'); - -#===Test transfer check=================================== - -push @R2,<<'EOF'; - - - -
-0.9 -
- - - -XCP -REPLY -DOMAIN -1 -Query successful -200 - - -pending_owner -0 -Transfer in progress - -1115213766 -Wed May 4 09:36:06 2005 - - - - - - +$cs=$dri->local_object('contactset'); +$co=$dri->local_object('contact'); +$co->name('JohnDoe'); +$co->org('NameAction DomainLA'); +$co->street(['1156 HighStreet','','']); +$co->city('California'); +$co->pc('95064'); +$co->cc('US'); +$co->voice('1.1234567'); +$co->email('j.doenameaction.com'); + +$cs->set($co,'registrant'); +$cs->set($co,'admin'); + +my $toc=$dri->local_object('changes'); +$toc->set('ns',$ns); +$toc->set('contact',$cs); + +$rc = $dri->domain_update('nameaction.cl',$toc); +is_string($R1,$r,'domain_update build'); +is($rc->is_success(),1,'domain_update is_success'); +is($dri->get_info('action'),'update','domain_update get_info(action)'); +is($dri->get_info('exist'),1,'domain_update get_info(exist)'); + +### Domain Info Error + +$r= "https://ncktest.nameaction.com/interface?User=ncktest&Pass=ncktest&Command=Info&SLD=nameaction&TLD=cl"; + +$R2 = <<'EOF'; + + + + 2311 + Domains are not associated with this account + + + EOF -$r=<<'EOF'; - - - -
-0.9 -
- - - -check_transfer -domain -XCP -216.40.46.115 - - -1 -catmas.com -1 - - - - - - +$rc = $dri->domain_info('nameaction.cl'); +is_string($R1,$r,'domain_info build'); +is($rc->is_success(),0,'domain_info error'); + +### Domain Specific Info + +$r= "https://ncktest.nameaction.com/interface?User=ncktest&Pass=ncktest&Command=Info&SLD=nameaction&TLD=cl"; + +$R2 = <<'EOF'; + + + Info + 1000 + + +
+ nameaction.cl + + NameAction Domain LA + John Doe + John Doe + + + ns1.nameaction.com + 200.27.54.210 + ns2.nameaction.com + 200.27.54.211 + + 2012-02-13 00:00:00 + Registred +
+ + EOF -$rc=$dri->domain_transfer_query('catmas.com',{username => 'daniel', password => 'guessthis', registrant_ip => '216.40.46.115'}); -is_string(munge(shift(@R1)),munge($r),'domain_transfer_query'); -is($rc->is_success(),1,'domain_transfer_query is_success'); -is($dri->get_info('transferrable'),0,'domain_transfer_query get_info(transferrable)'); -is($dri->get_info('reason'),'Transfer in progress','domain_transfer_query get_info(reason)'); -is($dri->get_info('unixtime'),1115213766,'domain_transfer_query get_info(reason)'); - -#===Test transfer cancel=================================== - -push @R2,<<'EOF'; - - - -
-0.9 -
- - - -XCP -REPLY -TRANSFER -Transfer with order id: 3533098 has been canceled. -1 -200 - - - - +$rc = $dri->domain_info('nameaction.cl'); +is_string($R1,$r,'domain_info build'); +is($rc->is_success(),1,'domain_info is_success'); +my $s=$dri->get_info('contact'); +isa_ok($s,'Net::DRI::Data::ContactSet','domain_info get_info(contact)'); +is_deeply([$s->types()],['admin','registrant','tech'],'domain_info get_info(contact) types'); +is($s->get('registrant')->name(),'NameAction Domain LA','domain_info get_info(contact) registrant name'); +is($s->get('admin')->name(),'John Doe','domain_info get_info(contact) admin name'); +is($s->get('tech')->name(),'John Doe','domain_info get_info(contact) tech name'); +my $dh=$dri->get_info('ns'); +isa_ok($dh,'Net::DRI::Data::Hosts','domain_info get_info(subordinate_hosts)'); +my @c=$dh->get_names(); +is_deeply(\@c,['ns1.nameaction.com','ns2.nameaction.com'],'domain_info get_info(host) get_names'); +my $d=$dri->get_info('expirydate'); +is($d,'2012-02-13 00:00:00','domain_info get_info(expirydate) value'); + +### Domain Info Error + +$r= "https://ncktest.nameaction.com/interface?User=ncktest&Pass=ncktest&Command=Delete&SLD=nameaction&TLD=cl"; + +$R2 = <<'EOF'; + + + delete + 1000 + + + Request to Delete the domain nameaction.cl successfully received + + EOF -$r=<<"EOF"; - - - -
-0.9 -
- - - -cancel_transfer -transfer -XCP -216.40.46.115 - - -example.com -$RESELLERID - - - - - - +$rc = $dri->domain_delete('nameaction.cl', { pure_delete => 1 }); +is_string($R1,$r,'domain_delete build'); +is($rc->is_success(),1,'domain_delete is_success'); + +### Transfer + +$r= 'https://ncktest.nameaction.com/interface?User=ncktest&Pass=ncktest&Command=Transfer&Type=Management&SLD=nameaction&TLD=cl&AuthCode=ABC1234'; + +$R2 = <<'EOF'; + + + transfer + 1000 + + + Request to Transfer the domain nameaction.cl successfully received + + EOF -$rc=$dri->domain_transfer_stop('example.com',{username => 'daniel', password => 'guessthis', registrant_ip => '216.40.46.115', reseller_id => $RESELLERID}); -is_string(munge(shift(@R1)),munge($r),'domain_transfer_stop'); -is($rc->is_success(),1,'domain_transfer_stop is_success'); +$rc = $dri->domain_transfer_start('nameaction.cl', {auth=>{pw=>'ABC1234'}}); +is_string($R1,$r,'domain_transfer build'); +is($rc->is_success(),1,'domain_transfer is_success'); -exit 0; +### Trade +$r= 'https://ncktest.nameaction.com/interface?User=ncktest&Pass=ncktest&Command=Transfer&Type=Owner&SLD=nameaction&TLD=cl&RegistrantName=John+Doe&RegistrantOrganization=NameAction+Domain+LA&RegistrantAddress=1156+High+Street&RegistrantCity=California&RegistrantCountryCode=US&RegistrantPostalCode=95064&RegistrantPhone=1.1234567&RegistrantEmail=j.doe%40nameaction.com'; + +$R2 = <<'EOF'; + + + transfer + 1000 + + + Request to Transfer the domain nameaction.cl successfully received + + +EOF + +$cs=$dri->local_object('contactset'); +$co=$dri->local_object('contact'); +$co->name('John Doe'); +$co->org('NameAction Domain LA'); +$co->street(['1156 High Street','','']); +$co->city('California'); +$co->pc('95064'); +$co->cc('US'); +$co->voice('1.1234567'); +$co->email('j.doe@nameaction.com'); + +$cs->set($co,'registrant'); + +$rc = $dri->domain_trade_start('nameaction.cl', { contact => $cs }); +is_string($R1,$r,'domain_trade build'); +is($rc->is_success(),1,'domain_trade is_success'); + +exit 0; \ No newline at end of file From 13383846ccc3278a92ee1495067cd518e9c6bd85 Mon Sep 17 00:00:00 2001 From: pc-stein Date: Mon, 14 Mar 2022 11:44:25 +0000 Subject: [PATCH 07/12] Tests update --- lib/Net/DRI/Protocol/NameAction/Domain.pm | 2 -- t/Net/DRI/Protocol/NameAction.t | 2 +- 2 files changed, 1 insertion(+), 3 deletions(-) diff --git a/lib/Net/DRI/Protocol/NameAction/Domain.pm b/lib/Net/DRI/Protocol/NameAction/Domain.pm index 44d14d2a..97bc30ed 100644 --- a/lib/Net/DRI/Protocol/NameAction/Domain.pm +++ b/lib/Net/DRI/Protocol/NameAction/Domain.pm @@ -350,8 +350,6 @@ sub _build_all_ns return @hostnames, @ipv4; } - - sub _build_duration { my ($years) = @_; diff --git a/t/Net/DRI/Protocol/NameAction.t b/t/Net/DRI/Protocol/NameAction.t index 73c50fb4..9b978e6c 100755 --- a/t/Net/DRI/Protocol/NameAction.t +++ b/t/Net/DRI/Protocol/NameAction.t @@ -8,7 +8,7 @@ use Net::DRI::Data::Raw; use Net::DRI::Protocol::NameAction::Connection; use DateTime::Duration; use DateTime; -use Test::More tests => 45; +use Test::More tests => 34; eval { no warnings; require Test::LongString; Test::LongString->import(max => 100); $Test::LongString::Context=50; }; if ( $@ ) { no strict 'refs'; *{'main::is_string'}=\&main::is; } From 081ef41304f30aa4c1a8c5b71ab5a27aa1f43d24 Mon Sep 17 00:00:00 2001 From: pc-stein Date: Mon, 14 Mar 2022 15:48:32 +0000 Subject: [PATCH 08/12] Added tlds --- lib/Net/DRI/DRD/NameAction.pm | 24 ++++++++++++++++++++++-- 1 file changed, 22 insertions(+), 2 deletions(-) diff --git a/lib/Net/DRI/DRD/NameAction.pm b/lib/Net/DRI/DRD/NameAction.pm index e74444e6..6950f499 100644 --- a/lib/Net/DRI/DRD/NameAction.pm +++ b/lib/Net/DRI/DRD/NameAction.pm @@ -73,8 +73,28 @@ sub new sub periods { return map { DateTime::Duration->new(years => $_) } (1..10); } sub name { return 'NameAction'; } -sub tlds { return (qw/cl/, - ); } +sub tlds { + #my @tlds = qw/ai ar aw bo br cl co cr cu ec ga gt jm kn ng ni pa pe pr py sv uy ve/; + my @tlds = qw/ai ar aw bo cl co cr cu ec ga gt kn ni pa pe sv uy/; + my @ar = map {$_.'.ar'} qw/com net org/; + my @bo = map {$_.'.bo'} qw/com net org/; + my @br = map {$_.'.br'} qw/com eco emp esp etc ind inf net org radio rec srv tmp tv/; + my @cr = map {$_.'.cr'} qw/co/; + my @cu = map {$_.'.cu'} qw/com/; + my @jm = map {$_.'.jm'} qw/com/; + my @kn = map {$_.'.kn'} qw/com net org/; + my @ng = map {$_.'.ng'} qw/com/; + my @ni = map {$_.'.ni'} qw/biz co com/; + my @pa = map {$_.'.pa'} qw/com/; + my @pe = map {$_.'.pe'} qw/com org/; + my @pr = map {$_.'.pr'} qw/com/; + my @py = map {$_.'.py'} qw/com/; + my @sv = map {$_.'.sv'} qw/com/; + my @uy = map {$_.'.uy'} qw/com/; + my @ve = map {$_.'.ve'} qw/co com firm info net org rec web/; + + return @tlds,@ar,@bo,@br,@cr,@cu,@jm,@kn,@ng,@ni,@pa,@pe,@pr,@py,@sv,@uy,@ve; +} sub object_types { return ('domain'); } sub profile_types { return qw/nameaction/; } From 9b175a2aee7aa3a5102ac8ac253277b683c54462 Mon Sep 17 00:00:00 2001 From: pc-stein Date: Thu, 17 Mar 2022 15:56:56 +0000 Subject: [PATCH 09/12] Added Domains that can be used in nameaction, Nameaction contact, Manifest and tests --- MANIFEST | 7 ++ lib/Net/DRI/DRD/NameAction.pm | 123 ++++++++++++++++++---- lib/Net/DRI/Data/Contact/NameAction.pm | 116 ++++++++++++++++++++ lib/Net/DRI/Protocol/NameAction.pm | 6 +- lib/Net/DRI/Protocol/NameAction/Domain.pm | 17 +-- t/0_load_mandatory.t | 8 +- t/Net/DRI/Protocol/NameAction.t | 13 ++- 7 files changed, 255 insertions(+), 35 deletions(-) create mode 100644 lib/Net/DRI/Data/Contact/NameAction.pm diff --git a/MANIFEST b/MANIFEST index 3032b0b1..2f704cc4 100644 --- a/MANIFEST +++ b/MANIFEST @@ -45,6 +45,7 @@ lib/Net/DRI/Data/Contact/JOBS.pm lib/Net/DRI/Data/Contact/JP.pm lib/Net/DRI/Data/Contact/LU.pm lib/Net/DRI/Data/Contact/LV.pm +lib/Net/DRI/Data/Contact/NameAction.pm lib/Net/DRI/Data/Contact/Neustar.pm lib/Net/DRI/Data/Contact/NO.pm lib/Net/DRI/Data/Contact/Nominet.pm @@ -127,6 +128,7 @@ lib/Net/DRI/DRD/IRegistry.pm lib/Net/DRI/DRD/ISPAPI.pm lib/Net/DRI/DRD/KNET.pm lib/Net/DRI/DRD/LVRegistry.pm +lib/Net/DRI/DRD/NameAction.pm lib/Net/DRI/DRD/NASK.pm lib/Net/DRI/DRD/Neustar/IN.pm lib/Net/DRI/DRD/Neustar/Narwhal.pm @@ -509,6 +511,10 @@ lib/Net/DRI/Protocol/IRIS/LWZ.pm lib/Net/DRI/Protocol/IRIS/Message.pm lib/Net/DRI/Protocol/IRIS/XCP.pm lib/Net/DRI/Protocol/Message.pm +lib/Net/DRI/Protocol/NameAction.pm +lib/Net/DRI/Protocol/NameAction/Connection.pm +lib/Net/DRI/Protocol/NameAction/Domain.pm +lib/Net/DRI/Protocol/NameAction/Message.pm lib/Net/DRI/Protocol/OpenSRS/XCP.pm lib/Net/DRI/Protocol/OpenSRS/XCP/Account.pm lib/Net/DRI/Protocol/OpenSRS/XCP/Connection.pm @@ -739,6 +745,7 @@ t/Net/DRI/Protocol/EPP/Extensions/ZACR.t t/Net/DRI/Protocol/EPP/Message.t t/Net/DRI/Protocol/EPP/OnlyLocalExtensions.t t/Net/DRI/Protocol/Message.t +t/Net/DRI/Protocol/NameAction.t t/Net/DRI/Protocol/OpenSRS/XCP.t t/Net/DRI/Protocol/ResultStatus.t t/Net/DRI/Protocol/RRI.t diff --git a/lib/Net/DRI/DRD/NameAction.pm b/lib/Net/DRI/DRD/NameAction.pm index 6950f499..1dce8c05 100644 --- a/lib/Net/DRI/DRD/NameAction.pm +++ b/lib/Net/DRI/DRD/NameAction.pm @@ -74,26 +74,109 @@ sub new sub periods { return map { DateTime::Duration->new(years => $_) } (1..10); } sub name { return 'NameAction'; } sub tlds { - #my @tlds = qw/ai ar aw bo br cl co cr cu ec ga gt jm kn ng ni pa pe pr py sv uy ve/; - my @tlds = qw/ai ar aw bo cl co cr cu ec ga gt kn ni pa pe sv uy/; - my @ar = map {$_.'.ar'} qw/com net org/; - my @bo = map {$_.'.bo'} qw/com net org/; - my @br = map {$_.'.br'} qw/com eco emp esp etc ind inf net org radio rec srv tmp tv/; - my @cr = map {$_.'.cr'} qw/co/; - my @cu = map {$_.'.cu'} qw/com/; - my @jm = map {$_.'.jm'} qw/com/; - my @kn = map {$_.'.kn'} qw/com net org/; - my @ng = map {$_.'.ng'} qw/com/; - my @ni = map {$_.'.ni'} qw/biz co com/; - my @pa = map {$_.'.pa'} qw/com/; - my @pe = map {$_.'.pe'} qw/com org/; - my @pr = map {$_.'.pr'} qw/com/; - my @py = map {$_.'.py'} qw/com/; - my @sv = map {$_.'.sv'} qw/com/; - my @uy = map {$_.'.uy'} qw/com/; - my @ve = map {$_.'.ve'} qw/co com firm info net org rec web/; - - return @tlds,@ar,@bo,@br,@cr,@cu,@jm,@kn,@ng,@ni,@pa,@pe,@pr,@py,@sv,@uy,@ve; + my @tlds = qw/ae aero ag ai al am app ar art as asia at attorney aw az ba bb be bg bh bi bike biz bo bs by bz ca cam cc cd ch ci cl cloud club cm cn co com company coop cr cu cv cz de diamonds digital dj dk dm do domains dz ec edu ee equipment es eu farm fashion fi film fit fm fo fr futbol ga gd ge gf gg gi gl global gp gq gr group gs gt guru gy hk hn hr ht hu id in info international investments io ir is it jewelry jo jobs jp ki kn kr kz la lat law lawyer lc legal li life link lk love lt ltda lu lv ly ma madrid market marketing md me mg mk mn mobi moda mp mq ms mt museum mx my name net network ni nl no online org pa pe pet ph pk pl pr pro pt pw qa racing ro rocks rs ru rw sc sd se services sg shop si site sk ski sm sn solutions soy sr st store su support sv sx systems tc tech technology tel tg tienda tj tk tl tn to tools top trade travel tt tv tw ua uk uno us uy vacations vc vg vi vin vn watch website wedding win wine ws xxx/; + + my @ag = map {"$_.ag"} qw/co com net/; + my @ai = map {"$_.ai"} qw/com net/; + my @al = map {"$_.al"} qw/com/; + my @ao = map {"$_.ao"} qw/co it/; + my @ar = map {"$_.ar"} qw/com int net org tur/; + my @at = map {"$_.at"} qw/co/; + my @au = map {"$_.au"} qw/com/; + my @aw = map {"$_.aw"} qw/com/; + my @az = map {"$_.az"} qw/com/; + my @ba = map {"$_.ba"} qw/co/; + my @bd = map {"$_.bd"} qw/com/; + my @bh = map {"$_.bh"} qw/com/; + my @bo = map {"$_.bo"} qw/com int net org/; + my @br = map {"$_.br"} qw/abc adm adv agr aju am aparecida app arq art b belem bhz bib blog boavista bsb campinas caxias cim cnt com contagem coz cuiaba curitiba des det dev eco emp enf eng esp etc far flog floripa fm fortal foz geo goiania gru imb ind inf jab jampa jdf joinville log londrina macapa maceio manaus maringa med natal net niteroi odo ong org osasco palmas poa ppg pro psi radio rec recife rep ribeirao rio riobranco salvador sampa saobernardo seg sjc slz sorocaba srv tec teo the tmp tur tv udi vix vlog wiki/; + my @bs = map {"$_.bs"} qw/com net org/; + my @bw = map {"$_.bw"} qw/co/; + my @bz = map {"$_.bz"} qw/com net/; + my @ci = map {"$_.ci"} qw/co/; + my @cn = map {"$_.cn"} qw/bj com net org/; + my @co = map {"$_.co"} qw/com edu net nom org/; + my @com = map {"$_.com"} qw/br cn us/; + my @cr = map {"$_.cr"} qw/co fi or/; + my @cu = map {"$_.cu"} qw/com net/; + my @cv = map {"$_.cv"} qw/com/; + my @cw = map {"$_.cw"} qw/com/; + my @cy = map {"$_.cy"} qw/com/; + my @de = map {"$_.de"} qw/com/; + my @dk = map {"$_.dk"} qw/co/; + my @dm = map {"$_.dm"} qw/co/; + my @do = map {"$_.do"} qw/com net org web/; + my @dz = map {"$_.dz"} qw/com/; + my @ec = map {"$_.ec"} qw/com fin info net org/; + my @ee = map {"$_.ee"} qw/co/; + my @eg = map {"$_.eg"} qw/com/; + my @es = map {"$_.es"} qw/com/; + my @fj = map {"$_.fj"} qw/com/; + my @ge = map {"$_.ge"} qw/com/; + my @gh = map {"$_.gh"} qw/com/; + my @gn = map {"$_.gn"} qw/com/; + my @gp = map {"$_.gp"} qw/com/; + my @gr = map {"$_.gr"} qw/com/; + my @gt = map {"$_.gt"} qw/com ind net org/; + my @gy = map {"$_.gy"} qw/co com net/; + my @hk = map {"$_.hk"} qw/com/; + my @hn = map {"$_.hn"} qw/com net org/; + my @hr = map {"$_.hr"} qw/com/; + my @hu = map {"$_.hu"} qw/co/; + my @id = map {"$_.id"} qw/co web/; + my @il = map {"$_.il"} qw/co/; + my @in = map {"$_.in"} qw/co net/; + my @ir = map {"$_.ir"} qw/co/; + my @it = map {"$_.it"} qw/co/; + my @jm = map {"$_.jm"} qw/com net org/; + my @jo = map {"$_.jo"} qw/com/; + my @jp = map {"$_.jp"} qw/co gr ne/; + my @ke = map {"$_.ke"} qw/co info/; + my @ki = map {"$_.ki"} qw/com/; + my @kn = map {"$_.kn"} qw/co com net org/; + my @kr = map {"$_.kr"} qw/co ne or/; + my @kw = map {"$_.kw"} qw/com/; + my @ly = map {"$_.ly"} qw/com/; + my @ma = map {"$_.ma"} qw/co/; + my @mk = map {"$_.mk"} qw/com/; + my @mt = map {"$_.mt"} qw/com/; + my @mx = map {"$_.mx"} qw/com org/; + my @my = map {"$_.my"} qw/com/; + my @mz = map {"$_.mz"} qw/co/; + my @na = map {"$_.na"} qw/com/; + my @ng = map {"$_.ng"} qw/com/; + my @ni = map {"$_.ni"} qw/ac biz co com edu in info int net nom org pp web/; + my @nl = map {"$_.nl"} qw/co/; + my @no = map {"$_.no"} qw/co/; + my @nz = map {"$_.nz"} qw/co/; + my @om = map {"$_.om"} qw/co com/; + my @pa = map {"$_.pa"} qw/com org/; + my @pe = map {"$_.pe"} qw/com net nom org/; + my @pk = map {"$_.pk"} qw/com/; + my @pl = map {"$_.pl"} qw/com/; + my @pr = map {"$_.pr"} qw/com net org/; + my @pt = map {"$_.pt"} qw/co com/; + my @py = map {"$_.py"} qw/com coop net org/; + my @qa = map {"$_.qa"} qw/com/; + my @ro = map {"$_.ro"} qw/co com/; + my @ru = map {"$_.ru"} qw/com net org/; + my @sg = map {"$_.sg"} qw/com/; + my @sn = map {"$_.sn"} qw/com/; + my @sv = map {"$_.sv"} qw/com org/; + my @th = map {"$_.th"} qw/co/; + my @tr = map {"$_.tr"} qw/com/; + my @tt = map {"$_.tt"} qw/biz co com info name net org pro/; + my @tw = map {"$_.tw"} qw/com/; + my @ua = map {"$_.ua"} qw/co com/; + my @uk = map {"$_.uk"} qw/co org/; + my @uy = map {"$_.uy"} qw/com edu net org/; + my @uz = map {"$_.uz"} qw/co/; + my @ve = map {"$_.ve"} qw/arts co com firm info int net nom org rec store web/; + my @vi = map {"$_.vi"} qw/co com net/; + my @vn = map {"$_.vn"} qw/com/; + my @za = map {"$_.za"} qw/co/; + + return @tlds,@ag,@ai,@al,@ao,@ar,@at,@au,@aw,@az,@ba,@bd,@bh,@bo,@br,@bs,@bw,@bz,@ci,@cn,@co,@com,@cr,@cu,@cv,@cw,@cy,@de,@dk,@dm,@do,@dz,@ec,@ee,@eg,@es,@fj,@ge,@gh,@gn,@gp,@gr,@gt,@gy,@hk,@hn,@hr,@hu,@id,@il,@in,@ir,@it,@jm,@jo,@jp,@ke,@ki,@kn,@kr,@kw,@ly,@ma,@mk,@mt,@mx,@my,@mz,@na,@ng,@ni,@nl,@no,@nz,@om,@pa,@pe,@pk,@pl,@pr,@pt,@py,@qa,@ro,@ru,@sg,@sn,@sv,@th,@tr,@tt,@tw,@ua,@uk,@uy,@uz,@ve,@vi,@vn,@za; } sub object_types { return ('domain'); } sub profile_types { return qw/nameaction/; } diff --git a/lib/Net/DRI/Data/Contact/NameAction.pm b/lib/Net/DRI/Data/Contact/NameAction.pm new file mode 100644 index 00000000..58229664 --- /dev/null +++ b/lib/Net/DRI/Data/Contact/NameAction.pm @@ -0,0 +1,116 @@ +## Domain Registry Interface, Handling of contact data for NameAction +## +## Copyright (c) 2022 Paulo Castanheira . All rights reserved. +## +## This file is part of Net::DRI +## +## Net::DRI is free software; you can redistribute it and/or modify +## it under the terms of the GNU General Public License as published by +## the Free Software Foundation; either version 2 of the License, or +## (at your option) any later version. +## +## See the LICENSE file that comes with this distribution for more details. +#################################################################################################### + +package Net::DRI::Data::Contact::NameAction; + +use strict; +use warnings; + +use base qw/Net::DRI::Data::Contact/; + +=pod + +=head1 NAME + +Net::DRI::Data::Contact::NameAction - Handle NameAction contact data for Net::DRI + +=head1 DESCRIPTION + +This subclass of Net::DRI::Data::Contact adds validation for +NameAction specific data. + +=head1 SUPPORT + +For now, support questions should be sent to: + +Epaulo.s.castanheira@gmail.comE + +Please also see the SUPPORT file in the distribution. + +=head1 SEE ALSO + +http://www.dotandco.com/services/software/Net-DRI/ + +=head1 AUTHOR + +Paulo Castanheira Epaulo.s.castanheira@gmail.comE + +=head1 COPYRIGHT + +Copyright (c) 2022 Paulo Castanheira . +All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +See the LICENSE file that comes with this distribution for more details. + +=cut + +#################################################################################################### + +sub validate +{ + my ($self,$change)=@_; + $change||=0; + my @errs; + + if (!$change) + { + my @missing=grep { my $r=scalar $self->$_(); (defined $r && length $r)? 0 : 1 } qw/name org city cc pc voice email/; + Net::DRI::Exception::usererr_insufficient_parameters('Mandatory contact information missing: '.join('/',@missing)) if @missing; + } + + push @errs,'name' if ($self->name() && grep { !Net::DRI::Util::xml_is_normalizedstring($_,1,255) } ($self->name())); + push @errs,'org' if ($self->org() && grep { !Net::DRI::Util::xml_is_normalizedstring($_,undef,255) } ($self->org())); + + my @rs=($self->street()); + foreach my $i (0,1) + { + next unless defined $rs[$i]; + push @errs,'street' if ((ref($rs[$i]) ne 'ARRAY') || (@{$rs[$i]} > 3) || (grep { !Net::DRI::Util::xml_is_normalizedstring($_,undef,255) } @{$rs[$i]})); + } + + push @errs,'city' if ($self->city() && grep { !Net::DRI::Util::xml_is_normalizedstring($_,1,255) } ($self->city())); + push @errs,'pc' if ($self->pc() && grep { !Net::DRI::Util::xml_is_token($_,undef,16) } ($self->pc())); + push @errs,'cc' if ($self->cc() && grep { !Net::DRI::Util::xml_is_token($_,2,2) } ($self->cc())); + push @errs,'cc' if ($self->cc() && grep { !exists($Net::DRI::Util::CCA2{uc($_)}) } ($self->cc())); + + push @errs,'voice' if ($self->voice() && ! ($self->voice()=~m/^[0-9]{1,3}\.[0-9]{1,14}(?:x\d+)?$/)); + push @errs,'email' if ($self->email() && ! (Net::DRI::Util::xml_is_token($self->email(),1,undef) && Email::Valid->rfc822($self->email()))); + + ## Nothing checked for disclose + + Net::DRI::Exception::usererr_invalid_parameters('Invalid contact information: '.join('/',@errs)) if @errs; + + return 1; ## everything ok. +} + +#sub init +#{ +# my ($self,$what,$ndr)=@_; +# +# if ($what eq 'create') +# { +# $self->srid('auto') unless defined($self->srid()); ## we can not choose the ID +# my $a=$self->auth(); +# $self->auth({pw=>''}) unless ($a && (ref($a) eq 'HASH') && exists($a->{pw})); +# } +# return; +#} + +#################################################################################################### +1; diff --git a/lib/Net/DRI/Protocol/NameAction.pm b/lib/Net/DRI/Protocol/NameAction.pm index 9671b274..9d01df58 100644 --- a/lib/Net/DRI/Protocol/NameAction.pm +++ b/lib/Net/DRI/Protocol/NameAction.pm @@ -20,6 +20,7 @@ use warnings; use base qw(Net::DRI::Protocol); use Net::DRI::Protocol::NameAction::Message; +use Net::DRI::Data::Contact::NameAction; =pod @@ -45,7 +46,7 @@ Paulo Castanheira, Epaulo.s.castanheira@gmail.comE =head1 COPYRIGHT -Copyright (c) 2022 Patrick Mevzek . +Copyright (c) 2022 Paulo Castanheira . All rights reserved. This program is free software; you can redistribute it and/or modify @@ -66,7 +67,8 @@ sub new my $self=$c->SUPER::new($ctx); $self->name('nameaction'); $self->version('1.0.4'); - $self->factories('message',sub { my $m=Net::DRI::Protocol::NameAction::Message->new(); return $m; }); + $self->factories('message',sub { return Net::DRI::Protocol::NameAction::Message->new(); }); + $self->factories('contact',sub { return Net::DRI::Data::Contact::NameAction->new(); }); $self->capabilities('domain_update','contact',['set']); $self->capabilities('domain_update','ns',['set']); $self->_load($rp); diff --git a/lib/Net/DRI/Protocol/NameAction/Domain.pm b/lib/Net/DRI/Protocol/NameAction/Domain.pm index 97bc30ed..e3466dfb 100644 --- a/lib/Net/DRI/Protocol/NameAction/Domain.pm +++ b/lib/Net/DRI/Protocol/NameAction/Domain.pm @@ -313,16 +313,19 @@ sub _build_command sub _build_contact { my ($contact,$type) = @_; + + $contact->validate(); + my $add_ref = $contact->street(); Net::DRI::Exception::usererr_insufficient_parameters('at least 1 line of address is needed') unless $add_ref && ref($add_ref) eq 'ARRAY' && @$add_ref && $add_ref->[0]; - + my @fragments = ( - ucfirst($type).'Name' => $contact->name(), - ucfirst($type).'Organization' => $contact->org(), + ucfirst($type).'Name' => scalar($contact->name()), + ucfirst($type).'Organization' => scalar($contact->org()), ucfirst($type).'Address' => join(' ', grep {$_} @$add_ref), - ucfirst($type).'City' => $contact->city(), - ucfirst($type).'CountryCode' => $contact->cc(), - ucfirst($type).'PostalCode' => $contact->pc(), + ucfirst($type).'City' => scalar($contact->city()), + ucfirst($type).'CountryCode' => scalar($contact->cc()), + ucfirst($type).'PostalCode' => scalar($contact->pc()), ucfirst($type).'Phone' => $contact->voice(), ucfirst($type).'Email' => $contact->email(), ); @@ -341,7 +344,7 @@ sub _build_all_ns my ($hostname, $ipv4) = $ns->get_details($i); Net::DRI::Exception::usererr_insufficient_parameters("invalid host $1 hostname") unless Net::DRI::Util::is_hostname($hostname); - Net::DRI::Exception::usererr_insufficient_parameters('invalid host $1 ipv4') unless Net::DRI::Util::is_ipv4($ipv4->[0]); + Net::DRI::Exception::usererr_insufficient_parameters("invalid host $1 ipv4") unless Net::DRI::Util::is_ipv4($ipv4->[0]); push @hostnames, ('NS'.$i => $hostname); push @ipv4, ('IP'.$i => $ipv4->[0]) ; diff --git a/t/0_load_mandatory.t b/t/0_load_mandatory.t index ff77bf69..a500a761 100755 --- a/t/0_load_mandatory.t +++ b/t/0_load_mandatory.t @@ -2,7 +2,7 @@ use strict; use warnings; -use Test::More tests => 551; +use Test::More tests => 557; BEGIN { use_ok('Net::DRI'); @@ -34,6 +34,7 @@ use_ok('Net::DRI::Data::Contact::JOBS'); use_ok('Net::DRI::Data::Contact::JP'); use_ok('Net::DRI::Data::Contact::LU'); use_ok('Net::DRI::Data::Contact::LV'); +use_ok('Net::DRI::Data::Contact::NameAction'); use_ok('Net::DRI::Data::Contact::NominetMMX'); use_ok('Net::DRI::Data::Contact::Neustar'); use_ok('Net::DRI::Data::Contact::NO'); @@ -114,6 +115,7 @@ use_ok('Net::DRI::DRD::IRegistry'); use_ok('Net::DRI::DRD::ISPAPI'); use_ok('Net::DRI::DRD::KNET'); use_ok('Net::DRI::DRD::LVRegistry'); +use_ok('Net::DRI::DRD::NameAction'); use_ok('Net::DRI::DRD::NASK'); use_ok('Net::DRI::DRD::Neustar::IN'); use_ok('Net::DRI::DRD::Neustar::Narwhal'); @@ -491,6 +493,10 @@ use_ok('Net::DRI::Protocol::IRIS::LWZ'); use_ok('Net::DRI::Protocol::IRIS::Message'); use_ok('Net::DRI::Protocol::IRIS::XCP'); use_ok('Net::DRI::Protocol::Message'); +use_ok('Net::DRI::Protocol::NameAction'); +use_ok('Net::DRI::Protocol::NameAction::Connection'); +use_ok('Net::DRI::Protocol::NameAction::Domain'); +use_ok('Net::DRI::Protocol::NameAction::Message'); use_ok('Net::DRI::Protocol::OpenSRS::XCP'); use_ok('Net::DRI::Protocol::OpenSRS::XCP::Account'); use_ok('Net::DRI::Protocol::OpenSRS::XCP::Connection'); diff --git a/t/Net/DRI/Protocol/NameAction.t b/t/Net/DRI/Protocol/NameAction.t index 9b978e6c..8b37a435 100755 --- a/t/Net/DRI/Protocol/NameAction.t +++ b/t/Net/DRI/Protocol/NameAction.t @@ -8,7 +8,7 @@ use Net::DRI::Data::Raw; use Net::DRI::Protocol::NameAction::Connection; use DateTime::Duration; use DateTime; -use Test::More tests => 34; +use Test::More tests => 36; eval { no warnings; require Test::LongString; Test::LongString->import(max => 100); $Test::LongString::Context=50; }; if ( $@ ) { no strict 'refs'; *{'main::is_string'}=\&main::is; } @@ -52,7 +52,7 @@ is($dri->get_info('exist'),0,'domain_check get_info(exist)'); ### Create -$r="https://ncktest.nameaction.com/interface?User=ncktest&Pass=ncktest&Command=Create&SLD=nameaction&TLD=cl&Year=2&RegistrantName=JohnDoe&RegistrantOrganization=NameAction+DomainLA&RegistrantAddress=1156+HighStreet&RegistrantCity=California&RegistrantCountryCode=US&RegistrantPostalCode=95064&RegistrantPhone=1.1234567&RegistrantEmail=j.doenameaction.com&AdminName=JohnDoe&AdminOrganization=NameAction+DomainLA&AdminAddress=1156+HighStreet&AdminCity=California&AdminCountryCode=US&AdminPostalCode=95064&AdminPhone=1.1234567&AdminEmail=j.doenameaction.com&TechName=JohnDoe&TechOrganization=NameAction+DomainLA&TechAddress=1156+HighStreet&TechCity=California&TechCountryCode=US&TechPostalCode=95064&TechPhone=1.1234567&TechEmail=j.doenameaction.com&NS1=ns1.nameaction.com&NS2=ns2.nameaction.com&IP1=200.27.54.210&IP2=200.27.54.211&InfoPL=55555555-5"; +$r='https://ncktest.nameaction.com/interface?User=ncktest&Pass=ncktest&Command=Create&SLD=nameaction&TLD=cl&Year=2&RegistrantName=JohnDoe&RegistrantOrganization=NameAction+DomainLA&RegistrantAddress=1156+HighStreet&RegistrantCity=California&RegistrantCountryCode=US&RegistrantPostalCode=95064&RegistrantPhone=1.1234567&RegistrantEmail=j.doe%40nameaction.com&AdminName=JohnDoe&AdminOrganization=NameAction+DomainLA&AdminAddress=1156+HighStreet&AdminCity=California&AdminCountryCode=US&AdminPostalCode=95064&AdminPhone=1.1234567&AdminEmail=j.doe%40nameaction.com&TechName=JohnDoe&TechOrganization=NameAction+DomainLA&TechAddress=1156+HighStreet&TechCity=California&TechCountryCode=US&TechPostalCode=95064&TechPhone=1.1234567&TechEmail=j.doe%40nameaction.com&NS1=ns1.nameaction.com&NS2=ns2.nameaction.com&IP1=200.27.54.210&IP2=200.27.54.211&InfoPL=55555555-5'; $R2 = <<'EOF'; @@ -68,6 +68,8 @@ EOF $cs=$dri->local_object('contactset'); my $co=$dri->local_object('contact'); +isa_ok($co,'Net::DRI::Data::Contact::NameAction','local_object(contact)'); + $co->name('JohnDoe'); $co->org('NameAction DomainLA'); $co->street(['1156 HighStreet','','']); @@ -75,7 +77,7 @@ $co->city('California'); $co->pc('95064'); $co->cc('US'); $co->voice('1.1234567'); -$co->email('j.doenameaction.com'); +$co->email('j.doe@nameaction.com'); $cs->set($co,'registrant'); $cs->set($co,'admin'); @@ -119,7 +121,7 @@ is($dri->get_info('exist'),1,'domain_renew get_info(exist)'); ### Update -$r="https://ncktest.nameaction.com/interface?User=ncktest&Pass=ncktest&Command=Modify&SLD=nameaction&TLD=cl&RegistrantName=JohnDoe&RegistrantOrganization=NameAction+DomainLA&RegistrantAddress=1156+HighStreet&RegistrantCity=California&RegistrantCountryCode=US&RegistrantPostalCode=95064&RegistrantPhone=1.1234567&RegistrantEmail=j.doenameaction.com&AdminName=JohnDoe&AdminOrganization=NameAction+DomainLA&AdminAddress=1156+HighStreet&AdminCity=California&AdminCountryCode=US&AdminPostalCode=95064&AdminPhone=1.1234567&AdminEmail=j.doenameaction.com&NS1=ns1.nameaction.com&NS2=ns2.nameaction.com&IP1=200.27.54.210&IP2=200.27.54.211"; +$r="https://ncktest.nameaction.com/interface?User=ncktest&Pass=ncktest&Command=Modify&SLD=nameaction&TLD=cl&RegistrantName=JohnDoe&RegistrantOrganization=NameAction+DomainLA&RegistrantAddress=1156+HighStreet&RegistrantCity=California&RegistrantCountryCode=US&RegistrantPostalCode=95064&RegistrantPhone=1.1234567&RegistrantEmail=j.doe%40nameaction.com&AdminName=JohnDoe&AdminOrganization=NameAction+DomainLA&AdminAddress=1156+HighStreet&AdminCity=California&AdminCountryCode=US&AdminPostalCode=95064&AdminPhone=1.1234567&AdminEmail=j.doe%40nameaction.com&NS1=ns1.nameaction.com&NS2=ns2.nameaction.com&IP1=200.27.54.210&IP2=200.27.54.211"; $R2 = <<'EOF'; @@ -142,7 +144,7 @@ $co->city('California'); $co->pc('95064'); $co->cc('US'); $co->voice('1.1234567'); -$co->email('j.doenameaction.com'); +$co->email('j.doe@nameaction.com'); $cs->set($co,'registrant'); $cs->set($co,'admin'); @@ -213,6 +215,7 @@ is($rc->is_success(),1,'domain_info is_success'); my $s=$dri->get_info('contact'); isa_ok($s,'Net::DRI::Data::ContactSet','domain_info get_info(contact)'); is_deeply([$s->types()],['admin','registrant','tech'],'domain_info get_info(contact) types'); +isa_ok($co,'Net::DRI::Data::Contact::NameAction','domain_info get_info(contact)'); is($s->get('registrant')->name(),'NameAction Domain LA','domain_info get_info(contact) registrant name'); is($s->get('admin')->name(),'John Doe','domain_info get_info(contact) admin name'); is($s->get('tech')->name(),'John Doe','domain_info get_info(contact) tech name'); From 8ca513ac7312ef9c638e48763bffb27e9988ce24 Mon Sep 17 00:00:00 2001 From: pc-stein Date: Wed, 23 Mar 2022 01:18:27 +0000 Subject: [PATCH 10/12] Missing mandatory attrs? --- lib/Net/DRI/Data/Contact/NameAction.pm | 2 ++ 1 file changed, 2 insertions(+) diff --git a/lib/Net/DRI/Data/Contact/NameAction.pm b/lib/Net/DRI/Data/Contact/NameAction.pm index 58229664..aaf96c85 100644 --- a/lib/Net/DRI/Data/Contact/NameAction.pm +++ b/lib/Net/DRI/Data/Contact/NameAction.pm @@ -19,6 +19,8 @@ use warnings; use base qw/Net::DRI::Data::Contact/; +PACKAGE__->register_attributes(); + =pod =head1 NAME From fb1d3ab9157fed84e139a464f860eb29c24d9a83 Mon Sep 17 00:00:00 2001 From: pc-stein Date: Fri, 25 Mar 2022 10:06:35 +0000 Subject: [PATCH 11/12] Bug Fix --- lib/Net/DRI/Data/Contact/NameAction.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/Net/DRI/Data/Contact/NameAction.pm b/lib/Net/DRI/Data/Contact/NameAction.pm index aaf96c85..b3aa4877 100644 --- a/lib/Net/DRI/Data/Contact/NameAction.pm +++ b/lib/Net/DRI/Data/Contact/NameAction.pm @@ -19,7 +19,7 @@ use warnings; use base qw/Net::DRI::Data::Contact/; -PACKAGE__->register_attributes(); +__PACKAGE__->register_attributes(); =pod From 3632589031ccaa98438dcbf3e67dbfe79170bdfb Mon Sep 17 00:00:00 2001 From: pc-stein Date: Tue, 29 Mar 2022 16:40:02 +0100 Subject: [PATCH 12/12] Status and ExDate code corrections --- lib/Net/DRI/Protocol/NameAction.pm | 2 + lib/Net/DRI/Protocol/NameAction/Domain.pm | 4 +- lib/Net/DRI/Protocol/NameAction/Status.pm | 81 +++++++++++++++++++++++ t/Net/DRI/Protocol/NameAction.t | 8 +-- 4 files changed, 90 insertions(+), 5 deletions(-) create mode 100644 lib/Net/DRI/Protocol/NameAction/Status.pm diff --git a/lib/Net/DRI/Protocol/NameAction.pm b/lib/Net/DRI/Protocol/NameAction.pm index 9d01df58..7600be82 100644 --- a/lib/Net/DRI/Protocol/NameAction.pm +++ b/lib/Net/DRI/Protocol/NameAction.pm @@ -21,6 +21,7 @@ use base qw(Net::DRI::Protocol); use Net::DRI::Protocol::NameAction::Message; use Net::DRI::Data::Contact::NameAction; +use Net::DRI::Protocol::NameAction::Status; =pod @@ -69,6 +70,7 @@ sub new $self->version('1.0.4'); $self->factories('message',sub { return Net::DRI::Protocol::NameAction::Message->new(); }); $self->factories('contact',sub { return Net::DRI::Data::Contact::NameAction->new(); }); + $self->factories('status',sub { return Net::DRI::Protocol::NameAction::Status->new(); }); $self->capabilities('domain_update','contact',['set']); $self->capabilities('domain_update','ns',['set']); $self->_load($rp); diff --git a/lib/Net/DRI/Protocol/NameAction/Domain.pm b/lib/Net/DRI/Protocol/NameAction/Domain.pm index e3466dfb..4815c07e 100644 --- a/lib/Net/DRI/Protocol/NameAction/Domain.pm +++ b/lib/Net/DRI/Protocol/NameAction/Domain.pm @@ -224,7 +224,9 @@ sub info_parse $rinfo->{domain}->{$oname}->{ns}=$nso; } - $rinfo->{domain}->{$oname}->{expirydate}=$ra->{expiry_date}; + my $strp=$nma->build_strptime_parser(pattern => '%F %T'); + $rinfo->{domain}->{$oname}->{exDate}=$strp->parse_datetime($ra->{expiry_date}); + $rinfo->{domain}->{$oname}->{status}=$nma->create_local_object('status')->add($ra->{status}); } sub delete diff --git a/lib/Net/DRI/Protocol/NameAction/Status.pm b/lib/Net/DRI/Protocol/NameAction/Status.pm new file mode 100644 index 00000000..739b5d7d --- /dev/null +++ b/lib/Net/DRI/Protocol/NameAction/Status.pm @@ -0,0 +1,81 @@ +## Domain Registry Interface, NameAction Status +## +## Copyright (c) 2022 Paulo Castanheira . All rights reserved. +## +## This file is part of Net::DRI +## +## Net::DRI is free software; you can redistribute it and/or modify +## it under the terms of the GNU General Public License as published by +## the Free Software Foundation; either version 2 of the License, or +## (at your option) any later version. +## +## See the LICENSE file that comes with this distribution for more details. +######################################################################################### + +package Net::DRI::Protocol::NameAction::Status; + +use base qw!Net::DRI::Data::StatusList!; + +use strict; +use warnings; + +use Net::DRI::Exception; + +=pod + +=head1 NAME + +Net::DRI::Protocol::NameAction::Status - NameAction Status for Net::DRI + +=head1 DESCRIPTION + +Please see the README file for details. + +=head1 SUPPORT + +For now, support questions should be sent to: + +Epaulo.s.castanheira@gmail.comE + +Please also see the SUPPORT file in the distribution. + +=head1 AUTHOR + +Paulo Castanheira, Epaulo.s.castanheira@gmail.comE + +=head1 COPYRIGHT + +Copyright (c) 2022 Paulo Castanheira . +All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +See the LICENSE file that comes with this distribution for more details. + +=cut + +####################################################################################### + +sub new +{ + my ($class,$msg)=@_; + my $self=$class->SUPER::new('nameaction','1.0.4'); + return $self unless defined $msg; + Net::DRI::Exception::err_invalid_parameters('new() expects a ref array') unless ref $msg eq 'ARRAY'; + $self->add(@$msg); + return $self; + +} + +sub is_active { return shift->has_any('Registered'); } +sub is_pending { return shift->has_any('In Process'); } +sub can_update { return !shift->is_pending(); } +sub can_transfer { return !shift->is_pending(); } +sub can_delete { return !shift->is_pending(); } +sub can_renew { return !shift->is_pending(); } + +####################################################################################### +1; diff --git a/t/Net/DRI/Protocol/NameAction.t b/t/Net/DRI/Protocol/NameAction.t index 8b37a435..7440e31a 100755 --- a/t/Net/DRI/Protocol/NameAction.t +++ b/t/Net/DRI/Protocol/NameAction.t @@ -8,7 +8,7 @@ use Net::DRI::Data::Raw; use Net::DRI::Protocol::NameAction::Connection; use DateTime::Duration; use DateTime; -use Test::More tests => 36; +use Test::More tests => 37; eval { no warnings; require Test::LongString; Test::LongString->import(max => 100); $Test::LongString::Context=50; }; if ( $@ ) { no strict 'refs'; *{'main::is_string'}=\&main::is; } @@ -203,7 +203,7 @@ $R2 = <<'EOF'; 200.27.54.211 2012-02-13 00:00:00 - Registred + Registered @@ -223,8 +223,8 @@ my $dh=$dri->get_info('ns'); isa_ok($dh,'Net::DRI::Data::Hosts','domain_info get_info(subordinate_hosts)'); my @c=$dh->get_names(); is_deeply(\@c,['ns1.nameaction.com','ns2.nameaction.com'],'domain_info get_info(host) get_names'); -my $d=$dri->get_info('expirydate'); -is($d,'2012-02-13 00:00:00','domain_info get_info(expirydate) value'); +is($dri->get_info('exDate'),'2012-02-13T00:00:00','domain_info get_info(exDate) value'); +is_deeply([$dri->get_info('status')->list_status()],['Registered'],'domain_info get_info(status) list'); ### Domain Info Error