File Coverage

blib/lib/Net/EPP/Proxy.pm

Criterion	Covered	Total	%
statement	7	9	77.7
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	10	12	83.3

# Copyright (c) 2010 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: Proxy.pm,v 1.13 2007/12/03 11:44:19 gavin Exp $
package Net::EPP::Proxy;
use Carp;
use Digest::SHA1 qw(sha1_hex);
use Net::EPP::Simple;
use Net::EPP::Protocol;
use POSIX qw(strftime);
use Time::HiRes qw(time);
use XML::LibXML;
use bytes;
use base qw(Net::Server::Multiplex);
use constant EPP_XMLNS	=> 'urn:ietf:params:xml:ns:epp-1.0';
use vars qw($VERSION);
use strict;

our $VERSION = '0.04';

sub new {
	my $package = shift;
	my $self = $package->SUPER::new;
	$self->{epp} = {parser => XML::LibXML->new};
	bless($self, $package);
	return $self;
}

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

	$self->{epp}->{host}		= $params{remote_host};
	$self->{epp}->{port}		= $params{remote_port};
	$self->{epp}->{ssl}		= $params{ssl};
	$self->{epp}->{timeout}		= (int($params{req_timeout}) > 0 ? int($params{req_timeout}) : 5);
	$self->{epp}->{clid}		= $params{clid};
	$self->{epp}->{pw}		= $params{pw};
	$self->{epp}->{svcs}		= $params{svcs};
	$self->{epp}->{debug}		= $params{debug};

	# connect to the server:
	my ($code, $msg) = $self->epp_connect;

	# check the response:
	if ($code != 1000) {
		carp('Unable to log into to server using supplied credentials: '.$msg);
		return undef;
	}

	# run the main server loop:
	return $self->run(%params);
}

sub epp_connect {
	my $self = shift;

	# build our EPP client:
	$self->{epp}->{client} = Net::EPP::Simple->new(
		host	=> $self->{epp}->{host},
		port	=> $self->{epp}->{port},
		user	=> $self->{epp}->{user},
		pass	=> $self->{epp}->{pass},
		ssl	=> $self->{epp}->{ssl},
		timeout	=> $self->{epp}->{timeout},
		debug	=> $self->{epp}->{debug},
		dom	=> 1,
	);

	if (!$self->{epp}->{client}) {
		carp("Error connecting: $Net::EPP::Simple::Error");
		return ($Net::EPP::Simple::Code, "Error connecting: $Net::EPP::Simple::Error");
	}

	$self->{epp}->{greeting} = $self->{epp}->{client}->{greeting};

	return ($Net::EPP::Simple::Code, $Net::EPP::Simple::Message);
}

# new connection, send the greeting:
sub mux_connection {
	my ($self, $mux, $peer) = @_;
	print Net::EPP::Protocol->prep_frame($self->{net_server}->{epp}->{greeting}->toString);
}

# a request frame was received, transmit to remote server and return response to client:
sub mux_input {
	my ($self, $mux, $peer, $input) = @_;

	my $hdr		= substr(${$input}, 0, 4);
	my $length	= unpack('N', $hdr) - 4;
	my $question	= substr(${$input}, 4, $length);

	my $oldsig = $SIG{PIPE};
	$SIG{PIPE} = 'IGNORE';
	my $answer;
	eval {
		local $SIG{ALRM} = sub { die("timed out") };
		alarm($self->{net_server}->{epp}->{timeout});
		$answer = $self->{net_server}->{epp}->{client}->request($question);
		alarm(0);
	};
	$SIG{PIPE} = $oldsig;

	# initialise some things:
	my $err = '';
	my $fatal = 0;

	if ($@ ne '') {
		$err = sprintf('error getting answer from remote server: %s timeout %ds)', $@, $self->{net_server}->{epp}->{timeout});

	} elsif (length($answer->toString) < 1) {
		$err = sprintf('error getting answer from remote server: answer was %d bytes long', length($answer));

	} elsif ($self->get_result_code($answer) =~ /^(2500|2501|2502)$/) {
		$err = sprintf('session error at remote server (code %d)', $self->get_result_code($answer));

	}

	if ($err ne '') {
		$answer = $self->create_error_frame($question, $err);
		$self->debug("Fatal error from remote server: $err");
		$fatal = 1;
	}

	# send answer to client:
	print Net::EPP::Protocol->prep_frame($answer->toString);

	# clean up:
	$self->server_close if ($err ne '' && $fatal == 1);

	# clear the buffer:
	${$input} = '';

	return 1;
}

sub create_error_frame {
	my ($self, $question, $err) = @_;
	my $frame = Net::EPP::Frame::Response->new;

	my $clTRID;
	eval {
		my $doc = $self->{epp}->{parser}->parse_string($question);
		my $nodes = $doc->getElementsByTagNameNS(EPP_XMLNS, 'clTRID');
		my $node = $nodes->shift;
		my $text = ($node->getChildNodes)[0];
		$clTRID = $text->data;
		print STDERR $question;
	};

	my $msg = $frame->createElement('msg');
	$msg->appendText($err);

	$frame->clTRID->appendText($clTRID);
	$frame->svTRID->appendText(sha1_hex(ref($self).time().$$));

	$frame->result->setAttribute('code', 2500);
	$frame->result->appendChild($msg);

	return $frame;
}

sub get_result_code {
	my ($self, $doc) = @_;
	my $els = $doc->getElementsByTagNameNS(EPP_XMLNS, 'result');
	if (defined($els)) {
		my $el = $els->shift;
		if (defined($el)) {
			return $el->getAttribute('code');
		}
	}
	return 2400;
}

sub get_result_message {
	my ($self, $doc) = @_;
	my $els = $doc->getElementsByTagNameNS(EPP_XMLNS, 'msg');
	if (defined($els)) {
		my $el = $els->shift;
		if (defined($el)) {
			my @children = $el->getChildNodes;
			if (defined($children[0])) {
				my $txt = $children[0];
				return $txt->data if (ref($txt) eq 'XML::LibXML::Text');
			}
		}
	}
	return 'Unknown message';
}

1;

__END__