File Coverage

blib/lib/Net/DRI/Protocol/IRIS/LWZ.pm
Criterion Covered Total %
statement 30 89 33.7
branch 0 34 0.0
condition 0 6 0.0
subroutine 10 14 71.4
pod 0 4 0.0
total 40 147 27.2


line stmt bran cond sub pod time code
1             ## Domain Registry Interface, IRIS LWZ Connection handling
2             ##
3             ## Copyright (c) 2008-2010 Patrick Mevzek . All rights reserved.
4             ##
5             ## This file is part of Net::DRI
6             ##
7             ## Net::DRI is free software; you can redistribute it and/or modify
8             ## it under the terms of the GNU General Public License as published by
9             ## the Free Software Foundation; either version 2 of the License, or
10             ## (at your option) any later version.
11             ##
12             ## See the LICENSE file that comes with this distribution for more details.
13             ####################################################################################################
14              
15             package Net::DRI::Protocol::IRIS::LWZ;
16              
17 1     1   150450 use utf8;
  1         2  
  1         13  
18 1     1   207 use strict;
  1         2  
  1         56  
19 1     1   8 use warnings;
  1         23  
  1         60  
20              
21 1     1   8 use Net::DRI::Util;
  1         3  
  1         34  
22 1     1   7 use Net::DRI::Exception;
  1         3  
  1         30  
23 1     1   7 use Net::DRI::Data::Raw;
  1         2  
  1         14  
24 1     1   47 use Net::DRI::Protocol::ResultStatus;
  1         4  
  1         10  
25              
26 1     1   43 use Net::DNS ();
  1         6  
  1         25  
27              
28 1     1   7 use IO::Uncompress::RawInflate (); ## RFC1951 per the LWZ RFC
  1         2  
  1         26  
29 1     1   11 use IO::Compress::RawDeflate ();
  1         2  
  1         1457  
30              
31             =pod
32              
33             =head1 NAME
34              
35             Net::DRI::Protocol::IRIS::LWZ - IRIS LWZ connection handling (RFC4993) for Net::DRI
36              
37             =head1 DESCRIPTION
38              
39             Please see the README file for details.
40              
41             =head1 SUPPORT
42              
43             For now, support questions should be sent to:
44              
45             Enetdri@dotandco.comE
46              
47             Please also see the SUPPORT file in the distribution.
48              
49             =head1 SEE ALSO
50              
51             Ehttp://www.dotandco.com/services/software/Net-DRI/E
52              
53             =head1 AUTHOR
54              
55             Patrick Mevzek, Enetdri@dotandco.comE
56              
57             =head1 COPYRIGHT
58              
59             Copyright (c) 2008-2010 Patrick Mevzek .
60             All rights reserved.
61              
62             This program is free software; you can redistribute it and/or modify
63             it under the terms of the GNU General Public License as published by
64             the Free Software Foundation; either version 2 of the License, or
65             (at your option) any later version.
66              
67             See the LICENSE file that comes with this distribution for more details.
68              
69             =cut
70              
71             ####################################################################################################
72              
73             sub read_data # §3.1.2
74             {
75 0     0 0   my ($class,$to,$sock)=@_;
76              
77 0           my $data;
78 0 0         $sock->recv($data,4000) or die(Net::DRI::Protocol::ResultStatus->new_error('COMMAND_FAILED_CLOSING','Unable to read registry reply: '.$!,'en'));
79 0           my $hdr=substr($data,0,1);
80 0 0         die(Net::DRI::Protocol::ResultStatus->new_error('COMMAND_FAILED_CLOSING','Unable to read 1 byte header','en')) unless $hdr;
81             # §3.1.3
82 0           $hdr=unpack('C',$hdr);
83 0           my $ver=($hdr & (128+64)) >> 6;
84 0 0         die(Net::DRI::Protocol::ResultStatus->new_error('COMMAND_SYNTAX_ERROR','Version unknown in header: '.$ver,'en')) unless $ver==0;
85 0           my $rr=($hdr & 32) >> 5;
86 0 0         die(Net::DRI::Protocol::ResultStatus->new_error('COMMAND_SYNTAX_ERROR','RR Flag is not response in header: '.$rr,'en')) unless $rr==1;
87 0           my $deflate=($hdr & 16) >> 4; ## if 1, the payload is compressed with the deflate algorithm (RFC1951)
88 0           my $type=($hdr & 3); ## §3.1.4
89 0 0         die(Net::DRI::Protocol::ResultStatus->new_error('COMMAND_SYNTAX_ERROR','Unexpected response type in header: '.$type,'en')) unless $type==0; ## TODO : handle size info, version, etc.
90              
91 0           my $tid=substr($data,1,2);
92 0           $tid=unpack('n',$tid);
93 0           my $load=substr($data,3);
94 0 0         if ($deflate)
95             {
96 0           my $load2;
97 0 0         IO::Uncompress::RawInflate::rawinflate(\$load,\$load2) or die(Net::DRI::Protocol::ResultStatus->new_error('COMMAND_FAILED','Unable to uncompress payload: '.$IO::Uncompress::RawInflate::RawInflateError,'en'));
98 0           $load=$load2;
99             }
100              
101 0           my $m=Net::DRI::Util::decode_utf8($load);
102 0 0         die(Net::DRI::Protocol::ResultStatus->new_error('COMMAND_SYNTAX_ERROR',$m? 'Got unexpected reply message: '.$m : '','en')) unless ($m=~m!\s*$!s); ## we do not handle other things than plain responses (see Message)
    0          
103 0           return Net::DRI::Data::Raw->new_from_xmlstring($m);
104             }
105              
106             sub write_message
107             {
108 0     0 0   my ($self,$to,$msg)=@_;
109 0           my $m=Net::DRI::Util::encode_utf8($msg);
110 0           my $hdr='00001000'; ## §3.1.3 : V=0 RR=Request PD=no DS=yes Reserved PT=xml
111              
112             ## If not specificed in DRD, other option is to try anyway & fallback based on reply (this will need multiple exchanges, so probably some changes in Net::DRI::Registry::process)
113 0           my $deflate=$msg->options()->{request_deflate};
114 0 0 0       if ($deflate==2 || ($deflate==1 && length $m > 1500)) ## Deflate if forced or if message is over 1500 bytes (per RFC)
      0        
115             {
116 0           my $mm;
117 0           IO::Compress::RawDeflate::rawdeflate( \$m,\$mm);
118 0           $m=$mm;
119 0           $hdr='00011000';
120             }
121              
122 0           my ($tid)=($msg->tid()=~m/(\d{6})$/); ## 16 digits, we need to convert to a 16-bit value, we take the microsecond part modulo 65535 (since 0xFFFF is reserved)
123 0           $tid%=65535;
124 0           my $auth=$msg->authority();
125 0           return pack('B8',$hdr).pack('n',$tid).pack('n',4000).pack('C',length($auth)).$auth.$m; ## §3.1.1
126             }
127              
128             ## TODO: move that someway into IRIS/Core probably (as needed for all transports)
129             sub find_remote_server
130             {
131 0     0 0   my ($class,$to,$rd)=@_;
132 0           my ($authority,$service)=@$rd;
133              
134 0           my $res=Net::DNS::Resolver->new(domain=>'', search=>''); ## make sure to start from clean state (otherwise we inherit the system defaults !)
135 0           my $query=$res->send($authority,'NAPTR');
136 0 0         Net::DRI::Exception->die(1,'transport/socket',8,'No remote endpoint given, and unable to perform NAPTR DNS query for '.$authority.': '.$res->errorstring()) unless $query;
137              
138 0 0         my @r=sort { $a->order() <=> $b->order() || $a->preference() <=> $b->preference() } grep { $_->type() eq 'NAPTR' } $query->answer(); ## RFC3958 §2.2.1
  0            
  0            
139 0           @r=grep { $_->service() eq $service } @r; ## RFC3958 §2.2.2
  0            
140 0           @r=grep { $_->flags() eq 's' } @r; ## RFC3958 §2.2.3
  0            
141 0 0         Net::DRI::Exception->die(1,'transport/socket',8,'No remote endpoint given, and unable to retrieve NAPTR records with service='.$service.' and flags=s for authority='.$authority) unless @r;
142              
143 0           my $srv=$r[0]->replacement();
144 0           $query=$res->query($srv,'SRV');
145 0 0         Net::DRI::Exception->die(1,'transport/socket',8,'No remote endpoint given, and unable to perform SRV DNS query for '.$srv.': '.$res->errorstring()) unless $query;
146              
147 0           @r=$query->answer();
148 0 0         Net::DRI::Exception->die(1,'transport/socket',8,'No remote endpoint given, and unable to retrieve SRV records for '.$srv) unless @r;
149              
150             ## TODO: provide load balancing/fail over when not using only one SRV record / This would probably need changes in Transport or Transport::Socket
151 0 0         @r=Net::DRI::Util::dns_srv_order(@r) if @r > 1;
152 0 0         Net::DRI::Exception->die(1,'transport/socket',8,'No remote endpoint given, and unable to find valid SRV record for '.$srv) if ($r[0]->target() eq '.');
153 0           return ($r[0]->target(),$r[0]->port());
154             }
155              
156             sub transport_default
157             {
158 0     0 0   my ($self,$tname)=@_;
159             ## RFC4993 Section 4 gives recommandation for timeouts and retry algorithm
160             ## retry=5 is computed so that the whole sequence stops after 60 seconds: t,p+2t,3/2*(p+2)-2+4t,3/2*3/2*(p+2)-2+8t, ...
161 0           return (defer => 1, close_after => 1, socktype=>'udp', timeout => 1, pause => 2, retry => 5);
162             }
163              
164             ####################################################################################################
165             1;