## Domain Registry Interface, EPP Message
##
## Copyright (c) 2005,2006,2007,2008 Patrick Mevzek <netdri@dotandco.com>. 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::EPP::Message;

use strict;

use DateTime::Format::ISO8601 ();
use DateTime ();
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 command command_body cltrid svtrid msg_id node_resdata node_extension node_msg result_greeting));

our $VERSION=do { my @r=(q$Revision: 1.23 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); };

=pod

=head1 NAME

Net::DRI::Protocol::EPP::Message - EPP Message for Net::DRI

=head1 DESCRIPTION

Please see the README file for details.

=head1 SUPPORT

For now, support questions should be sent to:

E<lt>netdri@dotandco.comE<gt>

Please also see the SUPPORT file in the distribution.

=head1 SEE ALSO

E<lt>http://www.dotandco.com/services/software/Net-DRI/E<gt>

=head1 AUTHOR

Patrick Mevzek, E<lt>netdri@dotandco.comE<gt>

=head1 COPYRIGHT

Copyright (c) 2005,2006,2007,2008 Patrick Mevzek <netdri@dotandco.com>.
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 $proto=shift;
 my $class=ref($proto) || $proto;
 my $trid=shift;

 my $self={ results => [], ns => {} };
 bless($self,$class);

 $self->cltrid($trid) if (defined($trid) && $trid);
 return $self;
}

sub _get_result
{
 my ($self,$what,$pos)=@_;
 $pos=0 unless defined($pos);
 my $rh=$self->{results}->[$pos];
 return unless (defined($rh) && (ref($rh) eq 'HASH') && keys(%$rh)==4);
 return $rh->{$what};
}

## TODO : these are not very useful here, they should be done in ResultStatus
## (they are only used from t/241epp_message.t)
sub results            { return @{shift->{results}}; }
sub results_code       { return map { $_->{code} } shift->results(); }
sub results_message    { return map { $_->{message} } shift->results(); }
sub results_lang       { return map { $_->{lang} } shift->results(); }
sub results_extra_info { return map { $_->{extra_info} } shift->results(); }

sub result_code       { return shift->_get_result('code',@_); }
sub result_message    { return shift->_get_result('message',@_); }
sub result_lang       { return shift->_get_result('lang',@_); }
sub result_extra_info { return shift->_get_result('extra_info',@_); }

sub ns
{
 my ($self,$what)=@_;
 return $self->{ns} unless defined($what);

 if (ref($what) eq 'HASH')
 {
  $self->{ns}=$what;
  return $what;
 }
 return unless exists($self->{ns}->{$what});
 return $self->{ns}->{$what}->[0];
}

sub nsattrs
{
 my ($self,$what)=@_;
 return unless (defined($what) && exists($self->{ns}->{$what}));
 my @n=@{$self->{ns}->{$what}};
 return ($n[0],$n[0],$n[1]);
}

sub is_success { return _is_success(shift->result_code()); }
sub _is_success { return (shift=~m/^1/)? 1 : 0; } ## 1XXX is for success, 2XXX for failures

sub result_status
{
 my $self=shift;
 my $prev;

 foreach my $rs (reverse(@{$self->{results}}))
 {
  my $rso=Net::DRI::Protocol::ResultStatus->new('epp',$rs->{code},undef,_is_success($rs->{code}),$rs->{message},$rs->{lang},$rs->{extra_info});
  $rso->_set_trid([ $self->cltrid(),$self->svtrid() ]);
  $rso->_set_next($prev) if defined($prev);
  $prev=$rso;
 }
 return $prev;
}

sub command_extension_register
{
 my ($self,$ocmd,$ons)=@_;

 $self->{extension}=[] unless exists($self->{extension});
 my $eid=1+$#{$self->{extension}};
 $self->{extension}->[$eid]=[$ocmd,$ons,[]];
 return $eid;
}

sub command_extension
{
 my ($self,$eid,$rdata)=@_;

 if (defined($eid) && ($eid >= 0) && ($eid <= $#{$self->{extension}}) && defined($rdata) && (((ref($rdata) eq 'ARRAY') && @$rdata) || ($rdata ne '')))
 {
  $self->{extension}->[$eid]->[2]=(ref($rdata) eq 'ARRAY')? [ @{$self->{extension}->[$eid]->[2]}, @$rdata ] : $rdata;
 } else
 {
  return $self->{extension};
 }
}

sub as_string
{
 my ($self,$to)=@_;
 my $ens=sprintf('xmlns="%s" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xsi:schemaLocation="%s %s"',$self->nsattrs('_main'));
 my @d;
 push @d,'<?xml version="1.0" encoding="UTF-8" standalone="no"?>';
 push @d,'<epp '.$ens.'>';
 my ($cmd,$ocmd,$ons);
 my $rc=$self->command();
 ($cmd,$ocmd,$ons)=@$rc if (defined($rc) && ref($rc));

 my $attr='';
 ($cmd,$attr)=($cmd->[0],' '.join(' ',map { $_.'="'.$cmd->[1]->{$_}.'"' } keys(%{$cmd->[1]}))) if (defined($cmd) && ref($cmd));

 if (defined($cmd))
 {
  push @d,'<command>' if ($cmd ne 'hello');
  my $body=$self->command_body();
  if (defined($ocmd) && $ocmd)
  {
   push @d,'<'.$cmd.$attr.'>';
   push @d,'<'.$ocmd.' '.$ons.'>';
   push @d,Net::DRI::Util::xml_write($body);
   push @d,'</'.$ocmd.'>';
   push @d,'</'.$cmd.'>';
  } else
  {
   if (defined($body) && $body)
   {
    push @d,'<'.$cmd.$attr.'>';
    push @d,Net::DRI::Util::xml_write($body);
    push @d,'</'.$cmd.'>';
   } else
   {
    push @d,'<'.$cmd.$attr.'/>';
   }
  }
 }

 ## OPTIONAL extension
 my $ext=$self->{extension};
 if (defined($ext) && (ref($ext) eq 'ARRAY') && @$ext)
 {
  push @d,'<extension>';
  foreach my $e (@$ext)
  {
   my ($ecmd,$ens,$rdata)=@$e;
   if ($ecmd && $ens)
   {
    push @d,'<'.$ecmd.' '.$ens.'>';
    push @d,ref($rdata)? Net::DRI::Util::xml_write($rdata) : Net::DRI::Util::xml_escape($rdata);
    push @d,'</'.$ecmd.'>';
   } else
   {
    push @d,Net::DRI::Util::xml_escape(@$rdata);
   }
  }
  push @d,'</extension>';
 }

 ## OPTIONAL clTRID
 my $cltrid=$self->cltrid();
 if (defined($cmd) && ($cmd ne 'hello'))
 {
  push @d,'<clTRID>'.$cltrid.'</clTRID>' if (defined($cltrid) && $cltrid && Net::DRI::Util::xml_is_token($cltrid,3,64));
  push @d,'</command>';
 }
 push @d,'</epp>';

 return join('',@d);
}

sub get_response  { my $self=shift; return $self->_get_content($self->node_resdata(),@_); }
sub get_extension { my $self=shift; return $self->_get_content($self->node_extension(),@_); }

sub _get_content
{
 my ($self,$node,$nstag,$nodename)=@_;
 return unless (defined($node) && defined($nstag) && $nstag && defined($nodename) && $nodename);
 my $ns=$self->ns($nstag);
 $ns=$nstag unless defined($ns) && $ns;
 my @tmp=$node->getChildrenByTagNameNS($ns,$nodename);
 return unless @tmp;
 return $tmp[0];
}

sub parse
{
 my ($self,$dc,$rinfo)=@_;

 my $NS=$self->ns('_main');
 my $parser=XML::LibXML->new();
 my $doc=$parser->parse_string($dc->as_string());
 my $root=$doc->getDocumentElement();
 Net::DRI::Exception->die(0,'protocol/EPP',1,'Unsuccessfull parse, root element is not epp') unless ($root->getName() eq 'epp');

 if (my $g=$root->getChildrenByTagNameNS($NS,'greeting'))
 {
  push @{$self->{results}},{ code => 1000, message => undef, lang => undef, extra_info => []}; ## fake an OK
  $self->result_greeting($self->parse_greeting($g->shift()));
  return;
 }
 my $c=$root->getChildrenByTagNameNS($NS,'response');
 Net::DRI::Exception->die(0,'protocol/EPP',1,'Unsuccessfull parse, no response block') unless ($c->size()==1);
 my $res=$c->shift();

 ## result block(s)
 foreach my $result ($res->getChildrenByTagNameNS($NS,'result')) ## one element if success, multiple elements if failure RFC4930 §2.6
 {
  $self->parse_result($result);
 }

 $c=$res->getChildrenByTagNameNS($NS,'msgQ');
 $rinfo->{message}->{info}={ count => 0, checked_on => DateTime->now() };
 if ($c->size()) ## OPTIONAL
 {
  my $msgq=$c->shift();
  my $id=$msgq->getAttribute('id'); ## id of the message that has just been retrieved and dequeued (RFC4930) OR id of *next* available message (RFC3730)
  $rinfo->{message}->{info}->{id}=$id;
  $rinfo->{message}->{info}->{count}=$msgq->getAttribute('count');
  if ($msgq->hasChildNodes()) ## We will have childs only as a result of a poll request
  {
   my %d=( id => $id );
   $self->msg_id($id);
   $d{qdate}=DateTime::Format::ISO8601->new()->parse_datetime(($msgq->getChildrenByTagNameNS($NS,'qDate'))[0]->firstChild()->getData());
   my $msgc=($msgq->getChildrenByTagNameNS($NS,'msg'))[0];
   $d{lang}=$msgc->getAttribute('lang') || 'en';

   if (grep { $_->nodeType() == 1 } $msgc->childNodes())
   {
    $d{content}=$msgc->toString();
    $self->node_msg($msgc);
   } else
   {
    $d{content}=$msgc->firstChild()->getData();
   }
   $rinfo->{message}->{$id}=\%d;
  }
 }

 $c=$res->getChildrenByTagNameNS($NS,'resData');
 $self->node_resdata($c->shift()) if ($c->size()); ## OPTIONAL
 $c=$res->getChildrenByTagNameNS($NS,'extension');
 $self->node_extension($c->shift()) if ($c->size()); ## OPTIONAL

 ## trID
 my $trid=($res->getChildrenByTagNameNS($NS,'trID'))[0]; ## we search only for <trID> as direct child of <response>, hence getChildren and not getElements !
 my $tmp=extract_trids($trid,$NS,'clTRID');
 $self->cltrid($tmp) if defined($tmp);
 $tmp=extract_trids($trid,$NS,'svTRID');
 $self->svtrid($tmp) if defined($tmp);
}

sub extract_trids
{
 my ($trid,$NS,$what)=@_;
 my @tmp=$trid->getChildrenByTagNameNS($NS,$what);
 return unless @tmp && defined($tmp[0]) && defined($tmp[0]->firstChild());
 return $tmp[0]->firstChild()->getData();
}

sub parse_result
{
 my ($self,$node)=@_;
 my $code=$node->getAttribute('code');
 my $msg=($node->getChildrenByTagNameNS($self->ns('_main'),'msg'))[0];
 my $lang=$msg->getAttribute('lang') || 'en';
 $msg=$msg->firstChild()->getData();
 my @i;

 my $c=$node->getFirstChild();
 while ($c)
 {
  next unless ($c->nodeType() == 1); ## only for element nodes
  my $name=$c->nodeName();
  next unless $name;

  if ($name eq 'extValue') ## OPTIONAL
  {
   push @i,substr(substr($c->toString(),10),0,-11); ## grab everything as a string, without <extValue> and </extValue>
  } elsif ($name eq 'value') ## OPTIONAL
  {
   push @i,$c->toString();
  }
 } continue { $c=$c->getNextSibling(); }

 push @{$self->{results}},{ code => $code, message => $msg, lang => $lang, extra_info => \@i};
}

sub parse_greeting
{
 my ($self,$g)=@_;
 my %tmp;
 my $c=$g->getFirstChild();
 while($c)
 {
  next unless ($c->nodeType() == 1); ## only for element nodes
  my $n=$c->getName();
  if ($n=~m/^(svID|svDate)$/)
  {
   $tmp{$1}=$c->getFirstChild->getData();
  } elsif ($n eq 'svcMenu')
  {
   my $cc=$c->getFirstChild();
   while($cc)
   {
    next unless ($cc->nodeType() == 1); ## only for element nodes
    my $nn=$cc->getName();
    if ($nn=~m/^(version|lang)$/)
    {
     push @{$tmp{$1}},$cc->getFirstChild->getData();
    } elsif ($nn eq 'objURI')
    {
     push @{$tmp{svcs}},$cc->getFirstChild->getData();
    } elsif ($nn eq 'svcExtension')
    {
     push @{$tmp{svcext}},map { $_->getFirstChild->getData() } grep { $_->getName() eq 'extURI' } $cc->getChildNodes();
    }
   } continue { $cc=$cc->getNextSibling(); }
  } elsif ($n eq 'dcp')
  {
   ## TODO : do something with that data
  }
 } continue { $c=$c->getNextSibling(); }

 return \%tmp;
}

####################################################################################################
1;
