# Copyright (c) 2004 CentralNic Ltd. All rights reserved. This program is
# free software; you can redistribute it and/or modify it under the same
# terms as Perl itself.
# $Id: CNic.pm,v 1.27 2004/09/14 09:58:51 gavin Exp $

package WWW::CNic;
use vars qw($VERSION);
$VERSION = '0.08';

use LWP;
use HTTP::Request::Common;
use URI::Escape;
use Unicode::String qw(utf8);
use Digest::MD5 qw(md5_hex);
use strict;

=pod

=head1 NAME

WWW::CNic - a web-based API for the CentralNic domain registry system.

=head1 SYNOPSIS

	#
	# an example of a simple task performed through WWW::CNic:
	#

	use WWW::CNic;

	my @suffixlist = qw(uk.com us.com de.com eu.com);

	my $query = 	WWW::CNic->new(	command	=> 'search',
					domain	=> 'toolkit-test',
					use_ssl	=> 1,
					timeout	=> 5
			);

	$query->set(suffixlist => \@suffixlist);

	my $response = $query->execute();

	if ($response->is_error()) {
		print "ERROR: " . $response->error() . "\n";
	} else {
		foreach my $suffix(@suffixlist) {
			if ($response->is_registered()) {
				print "Domain $domain.$suffix is registered to ".$response->registrant($suffix)."\n";
			} else {
				print "Domain $domain.$suffix is available for registration.\n";
			}
		}
	}

=head1 DESCRIPTION

C<WWW::CNic> provides a powerful object-oriented Perl interface to the CentralNic Toolkit system. This system provides a way for CentralNic resellers to automate all Reseller-Registry communication and provides a far more flexible and efficient solution than the combination of whois + e-mail automaton that most registries operate.

The design of C<WWW::CNic> is inspired greatly by C<LWP>, which is a prerequisite. Essentially, making a transaction requires building a I<request> object, which is then executed and returns a I<response> object. While each transaction type (search, registration, modification...) requires a different set of data to be sent by the client, all the response objects have common properties, inherited from the C<WWW::CNic::Response> base class, with just a few extra methods for accessing specific information.

=head1 INSTALLATION

Installing C<WWW::CNic> is as simple as:

	cd /usr/src
	wget http://toolkit.centralnic.com/dist/perl/WWW-CNic-x.xx.tar.gz
	tar zxvf WWW-CNic-x.xx.tar.gz
	cd WWW-CNic-x.xx
	perl Makefile.PL
	make
	make install

=head1 PREREQUISITES

=over

=item 1

C<LWP> - the WWW Library for Perl. This in turn requires C<libnet>, C<URI> and C<HTML::Parser>.

=item 2

either C<Crypt::SSLeay> or C<IO::Socket::SSL> for doing SSL transactions.

=item 3

C<Unicode::String>. This is for correcting the character set of domain names.

=item 4

C<Digest::MD5> is needed for encrypting passwords.

=back

=head1 USAGE

Consult L<WWW::CNic::Cookbook> for detailed information on using WWW::CNic.

=head1 CONSTRUCTOR

	my $query = WWW::CNic->new( [OPTIONS] );

The constructor for this class accepts the following options:

=over

=item 1

C<username> - only needed for doing domain registrations and modifications. This is the User ID of your Reseller Handle.

=item 1

C<password> - the password for your Reseller Handle.

=item 2

C<use_ssl> - when set to C<1>, causes all transactions to take place over a Secure Sockets Layer (SSL) connection. This is highly recommended for domain registration and modification transactions, although it's probably not needed for the other commands.

In order to take advantage of this you need to have either the C<Crypt::SSLeay> or C<IO::Socket::SSL> modules installed. More information is available in the C<lwpcook> manpage.

=item 3

C<command> - required for every transaction. This may be one of the following:

	suffixes
	search
	whois
	register
	register_atgb
	modify
	renewals

=item 4

C<domain> - only needed for domain registrations and modifications.

=item 5

C<host> - allows you to use to a non-standard host. This is mainly useful for client debugging purposes.

=item 6

C<test> - when set to C<1>, this causes any domain registration and modification transactions to use the test database. Again, this is useful for testing and debugging.

=back

=head1 METHODS

	$query->set( NAME => VALUE );

This method allows you to set any number of parameters prior to executing the query. The specifics of what parameters are required for what type of transaction is explained in L<WWW::CNic::Cookbook>.

	my $response = $query->execute();

This method makes the transaction and returns an instance of a C<WWW::CNic::Response> child class.

=head1 COPYRIGHT

This module is (c) 2004 CentralNic Ltd. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself.

=head1 SEE ALSO

=over

=item *

http://toolkit.centralnic.com/

=item *

L<WWW::CNic::Cookbook>

=item *

L<WWW::CNic::Simple>

=back

=cut

sub new {
	# shift off the package name:
	my $package = shift;
	# convert to a hash:
	my %args = @_;
	# initialise the object:
	my $self = {};
	foreach my $key(keys %args) {
		$self->{"_$key"} = $args{$key};
	}
	# create an LWP useragent:
	$self->{_agent} = LWP::UserAgent->new();
	$self->{_agent}->timeout($self->{_timeout} || 10);
	$self->{_agent}->agent(sprintf('%s/%s (LWP %s, Perl %vd, %s)', $package, $VERSION, $LWP::VERSION, $^V, ucfirst($^O)));
	$self->{_base} = ($self->{_use_ssl} == 1 ? 'https' : 'http').'://'.($self->{_host} ne '' ? $self->{_host} : 'toolkit.centralnic.com').'/srv';
	# bless into this package:
	bless($self, $package);
	return $self;
}

sub set {
	my $self = shift;
	my %params = @_;
	foreach my $name(keys %params) {
		$self->{_params}{$name} = $params{$name};
	}
	return;
}

sub execute {
	my $self = shift;
	SWITCH: {
		$self->{_command} eq 'whois'		&& return $self->_whois();
		$self->{_command} eq 'search'		&& return $self->_search();
		$self->{_command} eq 'suffixes'		&& return $self->_suffixes();
		$self->{_command} eq 'create_handle'	&& return $self->_create_handle();
		$self->{_command} eq 'register'		&& return $self->_register();
		$self->{_command} eq 'register_idn'	&& return $self->_register(idn => 1);
		$self->{_command} eq 'register_atgb'	&& return $self->_register_atgb();
		$self->{_command} eq 'modify'		&& return $self->_modify();
		$self->{_command} eq 'renewals'		&& return $self->_upcoming_renewals();
		$self->{_command} eq 'list_domains'	&& return $self->_list_domains();
		$self->{_command} eq 'issue_renewals'	&& return $self->_issue_renewals();
		$self->{_command} eq 'get_pricing'	&& return $self->_get_pricing();
		$self->{_command} eq 'delete'		&& return $self->_delete_domain();
		$self->{_command} eq 'decline'		&& return $self->_decline_domain();
		die("Invalid command '$self->{_command}'");
	}
}

sub _whois {
	my $self = shift;
	die("Missing domain name") if $self->{_domain} eq '';
	$self->{_response}{_raw} = $self->_get(GET("$self->{_base}/wwwhois?domain=$self->{_domain}&test=$self->{_test}"));
	use WWW::CNic::Response::Whois;
	return WWW::CNic::Response::Whois->new($self->{_response}{_raw});
}

sub _search {
	my $self = shift;
	die("Missing domain name") if $self->{_domain} eq '';
	my $url = "$self->{_base}/search?domain=$self->{_domain}";
	if (defined(@{$self->{_params}{suffixlist}})) {
		$url .= '&suffixlist='.join(',', @{$self->{_params}{suffixlist}}).'&test='.$self->{_test};
	}
	$self->{_response}{_raw} = $self->_get(GET($url));
	use WWW::CNic::Response::Search;
	return WWW::CNic::Response::Search->new($self->{_response}{_raw});
}

sub _suffixes {
	my $self = shift;
	$self->{_response}{_raw} = $self->_get(GET("$self->{_base}/suffixes?test=$self->{_test}"));
	use WWW::CNic::Response::Suffixes;
	return WWW::CNic::Response::Suffixes->new($self->{_response}{_raw});
}

sub _create_handle {
	my $self = shift;
	die("Invalid type for handle") unless (ref($self->{_params}{handle}) eq 'HASH');
	my $handle = $self->_build_handle_string($self->{_params}{handle});
	my %params =  (
		user		=> $self->{_username},
		password	=> $self->_crypt_md5($self->{_password}),
		test		=> $self->{_test},
		handle		=> $handle,
	);
	my $req = HTTP::Request->new(POST => "$self->{_base}/create_handle");
	$req->content_type('application/x-www-form-urlencoded');
	my @content;
	foreach my $name(keys %params) {
		my $pair;
		if ($name eq 'dns[]') {
			$pair = "$name=$params{$name}";
		} else {
			$pair = uri_escape($name).'='.uri_escape($params{$name});
		}
		push(@content, $pair);
	}
	$req->content(join('&', @content));
	$self->{_response}{_raw} = $self->_get($req);
	use WWW::CNic::Response::CreateHandle;
	return WWW::CNic::Response::CreateHandle->new($self->{_response}{_raw});
}

sub _register {
	my $self = shift;
	my %args = @_;
	die("Missing domain name") if $self->{_domain} eq '';
	die("Missing username") if $self->{_username} eq '';
	die("Missing password") if $self->{_password} eq '';
	# convert to latin1:
	$self->{_domain} = utf8($self->{_domain})->latin1;
	my ($domain, $suffix) = split(/\./, $self->{_domain}, 2);
	my $chandle = (ref($self->{_params}{chandle}) eq 'HASH' ? $self->_build_handle_string($self->{_params}{chandle}) : $self->{_params}{chandle});
	my $thandle = (ref($self->{_params}{thandle}) eq 'HASH' ? $self->_build_handle_string($self->{_params}{thandle}) : $self->{_params}{thandle});
	my $dns;
	my $dns_param = 'dns[]';
	if (ref($self->{_params}{dns}) eq 'ARRAY') {
		$dns = join('&dns[]=', @{$self->{_params}{dns}});
	} elsif (ref($self->{_params}{dns}) eq 'HASH') {
		my @entries;
		foreach my $name(keys %{$self->{_params}{dns}}) {
			push(@entries, $name.'::'.${$self->{_params}{dns}}{$name});
		}
		$dns = join('&dns[]=', @entries);
	} elsif ($dns == 'defaults') {
		$dns = 'defaults';
		$dns_param = 'dns'
	}
	my %params = 	(
				user		=> $self->{_username},
				password	=> $self->_crypt_md5($self->{_password}),
				test		=> $self->{_test},
				domain		=> $domain,
				suffix		=> $suffix,
				registrant	=> $self->{_params}{registrant},
				chandle		=> $chandle,
				thandle		=> $thandle,
				period		=> $self->{_params}{period},
				$dns_param	=> $dns,
			);
	my $POST_URL = $self->{_base}.'/'.($args{idn} == 1 ? 'register_idn' : 'register');
	my $req = HTTP::Request->new(POST => $POST_URL);
	$req->content_type('application/x-www-form-urlencoded');
	my @content;
	foreach my $name(keys %params) {
		my $pair;
		if ($name eq 'dns[]') {
			$pair = "$name=$params{$name}";
		} else {
			$pair = uri_escape($name).'='.uri_escape($params{$name});
		}
		push(@content, $pair);
	}
	$req->content(join('&', @content));
	$self->{_response}{_raw} = $self->_get($req);
	use WWW::CNic::Response::Register;
	return WWW::CNic::Response::Register->new($self->{_response}{_raw});
}

sub _register_atgb {
	my $self = shift;
	die("Missing domain name") if $self->{_domain} eq '';
	die("Missing username") if $self->{_username} eq '';
	die("Missing password") if $self->{_password} eq '';
	my ($fname, $sname, $suffix) = split(/\./, $self->{_domain}, 3);
	my %params = 	(
				user		=> $self->{_username},
				password	=> $self->_crypt_md5($self->{_password}),
				test		=> $self->{_test},
				fname		=> $fname,
				sname		=> $sname,
				suffix		=> $suffix,
				registrant	=> $self->{_params}{registrant},
				handle		=> $self->_build_handle_string($self->{_params}{handle}),
				user_password	=> $self->{_params}{user_password},
				send_email	=> $self->{_params}{send_email}
			);
	my $req = HTTP::Request->new(POST => "$self->{_base}/register_atgb");
	$req->content_type('application/x-www-form-urlencoded');
	my @content;
	foreach my $name(keys %params) {
		my $pair = uri_escape($name).'='.uri_escape($params{$name});
		push(@content, $pair);
	}
	$req->content(join('&', @content));
	$self->{_response}{_raw} = $self->_get($req);
	use WWW::CNic::Response::Register::AtGB;
	return WWW::CNic::Response::Register::AtGB->new($self->{_response}{_raw});
}

sub _modify {
	my $self = shift;
	die("Missing domain name") if $self->{_domain} eq '';
	die("Missing username") if $self->{_username} eq '';
	die("Missing password") if $self->{_password} eq '';
	my %params = 	(
				user		=> $self->{_username},
				password	=> $self->_crypt_md5($self->{_password}),
				test		=> $self->{_test},
				domain		=> $self->{_domain},
			);
	if (defined($self->{_params}{thandle})) {
		$params{thandle} = (ref($self->{_params}{thandle}) eq 'HASH' ? $self->_build_handle_string($self->{_params}{thandle}) : $self->{_params}{thandle});
	}
	if (defined($self->{_params}{dns})) {
		my @dns;
		if (defined(@{$self->{_params}{dns}{drop}})) {
			foreach my $name(@{$self->{_params}{dns}{drop}}) {
				push(@dns, "drop:$name");
			}
		}
		if (defined(@{$self->{_params}{dns}{add}})) {
			foreach my $name(@{$self->{_params}{dns}{add}}) {
				push(@dns, "add:$name");
			}
		}
		$params{'dns[]'} = join('&dns[]=', @dns);
	}
	my $req = HTTP::Request->new( POST => "$self->{_base}/modify");
	$req->content_type('application/x-www-form-urlencoded');
	my @content;
	foreach my $name(keys %params) {
		my $pair;
		if ($name eq 'dns[]') {
			$pair = "$name=$params{$name}";
		} else {
			$pair = uri_escape($name).'='.uri_escape($params{$name});
		}
		push(@content, $pair);
	}
	$req->content(join('&', @content));
	$self->{_response}{_raw} = $self->_get($req);
	use WWW::CNic::Response::Modify;
	return WWW::CNic::Response::Modify->new($self->{_response}{_raw});
}

sub _upcoming_renewals {
	my $self = shift;
	die("Missing username") if $self->{_username} eq '';
	die("Missing password") if $self->{_password} eq '';
	my $url = "$self->{_base}/upcoming_renewals?user=$self->{_username}&months=$self->{_months}&password=".$self->_crypt_md5($self->{_password}).'&test='.$self->{_test};
	my $req = HTTP::Request->new(GET => $url);
	$self->{_response}{_raw} = $self->_get($req);
	use WWW::CNic::Response::Renewals;
	return WWW::CNic::Response::Renewals->new($self->{_response}{_raw});
}

sub _list_domains {
	my $self = shift;
	die("Missing username") if $self->{_username} eq '';
	die("Missing password") if $self->{_password} eq '';
	my %params = 	(
				user		=> $self->{_username},
				password	=> $self->_crypt_md5($self->{_password}),
				test		=> $self->{_test},
				offset		=> $self->{_params}{offset},
				length		=> $self->{_params}{length},
				orderby		=> $self->{_params}{orderby},
			);
	my $req = POST("$self->{_base}/list_domains", \%params);
	$self->{_response}{_raw} = $self->_get($req);
	use WWW::CNic::Response::DomainList;
	return WWW::CNic::Response::DomainList->new($self->{_response}{_raw});
}

sub _issue_renewals {
	my $self = shift;
	die("Missing username") if $self->{_username} eq '';
	die("Missing password") if $self->{_password} eq '';
	die("Missing domains") if scalar(@{$self->{_params}{domains}}) < 1;
	my %params = 	(
				user		=> $self->{_username},
				password	=> $self->_crypt_md5($self->{_password}),
				test		=> $self->{_test},
				period		=> $self->{_period},
				immediate	=> $self->{_params}->{immediate},
			);
	my $i = 0;
	foreach my $domain(@{$self->{_params}{domains}}) {
		$params{"domains[$i]"} = $domain;
		$i++;
	}
	my $req = POST("$self->{_base}/issue_renewals", \%params);
	$self->{_response}{_raw} = $self->_get($req);
	use WWW::CNic::Response::IssueRenewals;
	return WWW::CNic::Response::IssueRenewals->new($self->{_response}{_raw});
}

sub _get_pricing {
	my $self = shift;
	die("Missing username") if $self->{_username} eq '';
	die("Missing password") if $self->{_password} eq '';
	my %params = (
				user		=> $self->{_username},
				password	=> $self->_crypt_md5($self->{_password}),
				test		=> $self->{_test},
				type		=> $self->{_type},
	);
	my $url = "$self->{_base}/get_pricing";
	my $req = POST($url, \%params);
	$self->{_response}{_raw} = $self->_get($req);
	use WWW::CNic::Response::GetPricing;
	return WWW::CNic::Response::GetPricing->new($self->{_response}{_raw});
}

sub _delete_domain {
	my $self = shift;
	die("Missing username") if $self->{_username} eq '';
	die("Missing password") if $self->{_password} eq '';
	die("Missing reason")   if $self->{_reason} eq '';
	my %params = (
				user		=> $self->{_username},
				password	=> $self->_crypt_md5($self->{_password}),
				test		=> $self->{_test},
				domain		=> $self->{_domain},
				reason		=> $self->{_reason},
	);
	my $url = "$self->{_base}/delete_domain";
	my $req = POST($url, \%params);
	$self->{_response}{_raw} = $self->_get($req);
	use WWW::CNic::Response::DeleteDomain;
	return WWW::CNic::Response::DeleteDomain->new($self->{_response}{_raw});
}

sub _decline_domain {
	my $self = shift;
	die("Missing username") if $self->{_username} eq '';
	die("Missing password") if $self->{_password} eq '';
	my %params = (
				user		=> $self->{_username},
				password	=> $self->_crypt_md5($self->{_password}),
				test		=> $self->{_test},
				domain		=> $self->{_domain},
	);
	my $url = "$self->{_base}/decline_domain";
	my $req = POST($url, \%params);
	$self->{_response}{_raw} = $self->_get($req);
	use WWW::CNic::Response::DeclineDomain;
	return WWW::CNic::Response::DeclineDomain->new($self->{_response}{_raw});
}

sub _get {
	my ($self, $request) = @_;
	my $response = $self->{_agent}->request($request);
	if ($response->is_error()) {
		return "Status: 1\nMessage: ".$response->status_line();
	} else {
		return $response->content();
	}
}

sub _build_handle_string {
	my ($self, $data) = @_;
	my @str = ('new');
	foreach my $key(qw(name company address postcode country phone fax email)) {
		push(@str, ${$data}{$key});
	}
	return join("::", @str);
}

sub _salt {
	return join('', ('.', '/', 0..9, 'A'..'Z', 'a'..'z')[rand 64, rand 64]);
}

sub _crypt_md5 {
	my ($self, $str) = @_;
	my $salt = '$1$' . substr(md5_hex(rand()), 0, 8) . '$';
	my $crypted = crypt($str, $salt);
	return $crypted;
}

1;